diff --git a/cicecore/cicedyn/analysis/ice_diagnostics.F90 b/cicecore/cicedyn/analysis/ice_diagnostics.F90 index 3a6ceb83d..5a573c1bc 100644 --- a/cicecore/cicedyn/analysis/ice_diagnostics.F90 +++ b/cicecore/cicedyn/analysis/ice_diagnostics.F90 @@ -1722,7 +1722,7 @@ end subroutine init_diags subroutine debug_ice(iblk, plabeld) - character (char_len), intent(in) :: plabeld + character (len=*), intent(in) :: plabeld integer (kind=int_kind), intent(in) :: iblk ! local @@ -1772,7 +1772,7 @@ subroutine print_state(plabel,i,j,iblk) fsens, flat, evap, flwout, swvdr, swvdf, swidr, swidf, rhoa, & frzmlt, sst, sss, Tf, Tref, Qref, Uref, uocn, vocn, strtltxU, strtltyU - character (len=20), intent(in) :: plabel + character (len=*), intent(in) :: plabel integer (kind=int_kind), intent(in) :: & i, j , & ! horizontal indices @@ -1791,7 +1791,7 @@ subroutine print_state(plabel,i,j,iblk) logical (kind=log_kind) :: tr_fsd, tr_iso, tr_snow type (block) :: & - this_block ! block information for current block + this_block ! block information for current block character(len=*), parameter :: subname = '(print_state)' diff --git a/cicecore/cicedyn/infrastructure/comm/mpi/README.generate_haloupdates b/cicecore/cicedyn/infrastructure/comm/mpi/README.generate_haloupdates new file mode 100644 index 000000000..ac8f09fd0 --- /dev/null +++ b/cicecore/cicedyn/infrastructure/comm/mpi/README.generate_haloupdates @@ -0,0 +1,80 @@ + +How to Generate the ice_HaloUpdate subroutines quickly + +generate_haloUpdates.sh is a script that can generate the multiple +ice_HaloUpdate calls in ice_boundary.F90 to keep them all self-consistent. +The script uses a template to generate the various haloUpdate subroutines +depending on dimension and data type. It is implemented so it can be +used in both the mpi and serial directories. + +generate_haloUpdates.sh creates a file for each subroutine with a +name like HaloUpdate2DR8.subr. Those files are catted into HaloUpdate_all.subr +in the order those subroutines appear in ice_boundary.F90. The main +template in generate_haloUpdates.sh creates all the subroutines except +the 2DL1 subroutine. That subroutine is generated directly via a cat +near the bottom of the script because the 2DL1 implementation is unique. +It converts the logicals to integers, calls 2DI4, and then converts the +integers back to logicals. + +Remember that there are mpi and serial version of the ice_boundary.F90 +file and both should be updated and synchronized at the same time. + +The recommended usage is described below. + +1. Compare mpi and serial versions + + cd cicecore/cicedyn/infrastructure/comm/mpi + diff ../serial/ice_boundary.F90 ./ice_boundary.F90 + + ! The only difference should be a #define at the top of the file. + ! If there are other differences, it suggests someone updated one + ! file and not the other. Try to reconcile this first. + +2. Verify the current version of generate_haloUpdates.sh + + cd cicecore/cicedyn/infrastructure/comm/mpi + sed -n '/subroutine ice_HaloUpdate2DR8/,/end subroutine ice_HaloUpdate4DI4/p' ice_boundary.F90 >! HaloUpdate_all.current + ./generate_haloUpdates.sh + diff HaloUpdate_all.current HaloUpdate_all.subr + + ! Verify generate_haloUpdates.sh produces code that matches the current implementation in + ! ice_boundary.F90. If it doesn't, it suggests someone made manual changes to the subroutines + ! in ice_boundary.F90. Try to reconcile those differences and update generate_haloUpdates.sh first + +3. Update generate_haloUpdates.sh and generate new subroutines + + ! Modify generate_haloUpdates.sh to generate updated code then run + + ./generate_haloUpdates.sh + diff haloUpdate_all.current haloUpdate_all.subr + + ! Review diffences with the current code (HaloUpdate_all.current) + +4. Update ice_boundary.F90 + + ! When the changes are reasonable and as expected, edit ice_boundary.F90, cut out the code + ! between "subroutine ice_HaloUpdate2DR8" and "end subroutine ice_HaloUpdate4DI4" and replace + ! that code with the latest HaloUpdate_all.subr file. You can do it manually or try + + sed -e '/subroutine ice_HaloUpdate2DR8/,/end subroutine ice_HaloUpdate4DI4/c REPLACEHERE' ice_boundary.F90 >! tmpfile + sed -e '/REPLACEHERE/r HaloUpdate_all.subr' -e '/REPLACEHERE/d' tmpfile >! ice_boundary.F90.new + rm tmpfile + diff ice_boundary.F90 ice_boundary.F90.new + + ! There may be some extra blank lines or subroutine separators that need to be cleaned up at the + ! start or end of the replacement code, but then + + mv ice_boundary.F90.new ice_boundary.F90 + +5. Update serial version of ice_boundary.F90 + + ! Copy mpi/ice_boundary.F90 to serial/ice_boundary.F90 and add + + #define SERIAL_REMOVE_MPI + + ! to the top of the serial/ice_boundary.F90 code to turn off MPI in that version + +6. Test and test again + + ! Run both single and multi processor tests and iterate until done. + diff --git a/cicecore/cicedyn/infrastructure/comm/mpi/generate_haloUpdates.sh b/cicecore/cicedyn/infrastructure/comm/mpi/generate_haloUpdates.sh new file mode 100755 index 000000000..8e2093a0a --- /dev/null +++ b/cicecore/cicedyn/infrastructure/comm/mpi/generate_haloUpdates.sh @@ -0,0 +1,891 @@ +#!/bin/sh -f + +# This generates HaloUpdate*.subr files for each HaloUpdate method +# and a HaloUpdate_all.subr file for all the subroutines together +# Cut and paste this into ice_boundary.F90 +# Note 2DL1 is generated here, but separate, see below + +fileall=HaloUpdate_all.subr +echo "generate ${fileall}" +cat < ${fileall} + +!*********************************************************************** +EOF1 + +# generate subroutines + +for intfc in 2DR8 2DR4 2DI4 2DL1 3DR8 3DR4 3DI4 4DR8 4DR4 4DI4; do + +file=HaloUpdate${intfc}.subr +cdate=`date -u "+%F"` +echo "generate ${file}" + +#echo "intfc=${intfc}" +if ! [[ ${intfc} =~ 2DL1 ]]; then + + # replacement variables + + xtrdims="error" + xtrloop="error" + nzval="error" + ntval="error" + if [[ ${intfc} =~ 4D ]]; then + xtrdims=",:,:" + xtrloop=",k,l" + nzval="size(array, dim=3)" + ntval="size(array, dim=4)" + elif [[ ${intfc} =~ 3D ]]; then + xtrdims=",:" + xtrloop=",k" + nzval="size(array, dim=3)" + ntval="1" + elif [[ ${intfc} =~ 2D ]]; then + xtrdims="" + xtrloop="" + nzval="1" + ntval="1" + else + echo "ERROR, unmatched ${intfc} vs dimension" + exit -9 + fi + + dtype="error" + mtype="error" + zero="error" + half="error" + if [[ ${intfc} =~ R8 ]]; then + dtype="real (dbl_kind)" + mtype="MPIR8" + zero="0._dbl_kind" + half="(0.5_dbl_kind" + elif [[ ${intfc} =~ R4 ]]; then + dtype="real (real_kind)" + mtype="MPIR4" + zero="0._real_kind" + half="(0.5_real_kind" + elif [[ ${intfc} =~ I4 ]]; then + dtype="integer (int_kind)" + mtype="MPI_INTEGER" + zero="0" + half="nint(0.5_dbl_kind" + else + echo "ERROR, unmatched ${intfc} vs type" + exit -9 + fi + +# generate the subroutine + +cat < $file + + subroutine ice_HaloUpdate${intfc}(array, halo, & + fieldLoc, fieldKind, & + fillValue, tripoleOnly) + +! Generated by ${0} on ${cdate} +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. + +! This routine updates ghost cells for an input array and is a +! member of a group of routines under the generic interface +! ice\_HaloUpdate. + + type (ice_halo), intent(in) :: & + halo ! precomputed halo structure containing all + ! information needed for halo update + + integer (int_kind), intent(in) :: & + fieldKind, &! id for type of field (scalar, vector, angle) + fieldLoc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) + + ${dtype}, intent(in), optional :: & + fillValue ! optional value to put in ghost cells + ! where neighbor points are unknown + ! (e.g. eliminated land blocks or + ! closed boundaries) + + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + + ${dtype}, dimension(:,:${xtrdims},:), intent(inout) :: & + array ! array containing field for which halo + ! needs to be updated + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids + + ${dtype} :: & + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts + + logical (log_kind) :: & + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + ${dtype}, dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif + + character(len=*), parameter :: subname = '(ice_HaloUpdate${intfc})' + +!----------------------------------------------------------------------- +! +! abort or return on unknown or noupdate field_loc or field_type +! +!----------------------------------------------------------------------- + + if (fieldLoc == field_loc_unknown .or. & + fieldKind == field_type_unknown) then + call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed') + return + endif + + if (fieldLoc == field_loc_noupdate .or. & + fieldKind == field_type_noupdate) then + return + endif + +!----------------------------------------------------------------------- +! +! initialize error code and fill value +! +!----------------------------------------------------------------------- + + ewfillouter = .true. + nsfillouter = .true. + + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. + + if (present(fillValue)) then + fill = fillValue + ! always fill outer boundary if fillValue is passed + ewfillouter = .true. + nsfillouter = .true. + else + fill = ${zero} + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. + endif + + nz = ${nzval} + nt = ${ntval} + + nxGlobal = 0 + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! allocate request and status arrays for messages +! allocate send/recv buffers +! +!----------------------------------------------------------------------- + + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc${xtrloop},srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi${xtrdims},iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi${xtrdims},iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j${xtrdims},iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j${xtrdims},iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j${xtrdims},iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j${xtrdims},iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j${xtrdims},iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j${xtrdims},iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly + +!----------------------------------------------------------------------- +! +! do local copies while waiting for messages to complete +! if srcBlock is zero, that denotes an eliminated land block or a +! closed boundary where ghost cell values are undefined +! if srcBlock is less than zero, the message is a copy out of the +! tripole buffer and will be treated later +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numLocalCopies + iSrc = halo%srcLocalAddr(1,nmsg) + jSrc = halo%srcLocalAddr(2,nmsg) + srcBlock = halo%srcLocalAddr(3,nmsg) + iDst = halo%dstLocalAddr(1,nmsg) + jDst = halo%dstLocalAddr(2,nmsg) + dstBlock = halo%dstLocalAddr(3,nmsg) + + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst${xtrloop},dstBlock) = array(iSrc,jSrc${xtrloop},srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc${xtrloop},srcBlock) + end do + end do + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst${xtrloop},dstBlock) = fill + end do + end do + endif + endif + end do + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst${xtrloop},dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j${xtrdims},iblk) = array(ilo,j${xtrdims},iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j${xtrdims},iblk) = array(ilo,j${xtrdims},iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j${xtrdims},iblk)-array(ilo,j${xtrdims},iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j${xtrdims},iblk) = array(ihi,j${xtrdims},iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j${xtrdims},iblk) = array(ihi,j${xtrdims},iblk) + & + real((i),dbl_kind)*(array(ihi,j${xtrdims},iblk)-array(ihi-1,j${xtrdims},iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j${xtrdims},iblk) = array(i,jlo${xtrdims},iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j${xtrdims},iblk) = array(i,jlo${xtrdims},iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1${xtrdims},iblk)-array(i,jlo${xtrdims},iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j${xtrdims},iblk) = array(i,jhi${xtrdims},iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j${xtrdims},iblk) = array(i,jhi${xtrdims},iblk) + & + real((j),dbl_kind)*(array(i,jhi${xtrdims},iblk)-array(i,jhi-1${xtrdims},iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + +!----------------------------------------------------------------------- +! +! take care of northern boundary in tripole case +! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows +! (T-fold) of physical domain for entire (global) top row +! +!----------------------------------------------------------------------- + + if (nxGlobal > 0) then + + select case (fieldKind) + case (field_type_scalar) + isign = 1 + case (field_type_vector) + isign = -1 + case (field_type_angle) + isign = -1 + case default + call abort_ice(subname//'ERROR: Unknown field kind') + end select + + if (halo%tripoleTFlag) then + + select case (fieldLoc) + case (field_loc_center) ! cell center location + + ioffset = -1 + joffset = 0 + + !*** top row is degenerate, so must enforce symmetry + !*** use average of two degenerate points for value + + do l=1,nt + do k=1,nz + do i = 2,nxGlobal/2 + iDst = nxGlobal - i + 2 + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = ${half}*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do + end do + + case (field_loc_NEcorner) ! cell corner location + + ioffset = 0 + joffset = 1 + + case (field_loc_Eface) ! cell center location + + ioffset = 0 + joffset = 0 + + !*** top row is degenerate, so must enforce symmetry + !*** use average of two degenerate points for value + + do l=1,nt + do k=1,nz + do i = 1,nxGlobal/2 + iDst = nxGlobal + 1 - i + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = ${half}*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do + end do + + case (field_loc_Nface) ! cell corner (velocity) location + + ioffset = -1 + joffset = 1 + + case default + call abort_ice(subname//'ERROR: Unknown field location') + end select + + else ! tripole u-fold + + select case (fieldLoc) + case (field_loc_center) ! cell center location + + ioffset = 0 + joffset = 0 + + case (field_loc_NEcorner) ! cell corner location + + ioffset = 1 + joffset = 1 + + !*** top row is degenerate, so must enforce symmetry + !*** use average of two degenerate points for value + + do l=1,nt + do k=1,nz + do i = 1,nxGlobal/2 - 1 + iDst = nxGlobal - i + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = ${half}*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do + end do + + case (field_loc_Eface) ! cell center location + + ioffset = 1 + joffset = 0 + + case (field_loc_Nface) ! cell corner (velocity) location + + ioffset = 0 + joffset = 1 + + !*** top row is degenerate, so must enforce symmetry + !*** use average of two degenerate points for value + + do l=1,nt + do k=1,nz + do i = 1,nxGlobal/2 + iDst = nxGlobal + 1 - i + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = ${half}*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do + end do + + case default + call abort_ice(subname//'ERROR: Unknown field location') + end select + + endif + + !*** copy out of global tripole buffer into local + !*** ghost cells + + !*** look through local copies to find the copy out + !*** messages (srcBlock < 0) + + do nmsg=1,halo%numLocalCopies + srcBlock = halo%srcLocalAddr(3,nmsg) + + if (srcBlock < 0) then + + iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr + jSrc = halo%srcLocalAddr(2,nmsg) + + iDst = halo%dstLocalAddr(1,nmsg) ! local block addr + jDst = halo%dstLocalAddr(2,nmsg) + dstBlock = halo%dstLocalAddr(3,nmsg) + + !*** correct for offsets + iSrc = iSrc - ioffset + jSrc = jSrc - joffset + if (iSrc < 1 ) iSrc = iSrc + nxGlobal + if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal + + !*** for center and Eface on u-fold, and NE corner and Nface + !*** on T-fold, do not need to replace + !*** top row of physical domain, so jSrc should be + !*** out of range and skipped + !*** otherwise do the copy + + if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt + do k=1,nz + array(iDst,jDst${xtrloop},dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do + endif + + endif + end do + + endif + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + +!----------------------------------------------------------------------- + + end subroutine ice_HaloUpdate${intfc} + +EOFF + +else # if intfc eq 2DL1 + +# generate 2DL1 subroutine + +cat < ${file} + + subroutine ice_HaloUpdate2DL1(array, halo, & + fieldLoc, fieldKind, & + fillValue, tripoleOnly) + +! This routine updates ghost cells for an input array and is a +! member of a group of routines under the generic interface +! ice\_HaloUpdate. This routine is the specific interface +! for 2d horizontal logical arrays. + + type (ice_halo), intent(in) :: & + halo ! precomputed halo structure containing all + ! information needed for halo update + + integer (int_kind), intent(in) :: & + fieldKind, &! id for type of field (scalar, vector, angle) + fieldLoc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) + + logical (log_kind), intent(in), optional :: & + fillValue ! optional value to put in ghost cells + ! where neighbor points are unknown + ! (e.g. eliminated land blocks or + ! closed boundaries) + + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + + logical (log_kind), dimension(:,:,:), intent(inout) :: & + array ! array containing field for which halo + ! needs to be updated + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + istat ! allocate return status + + integer (int_kind), dimension(:,:,:), allocatable :: & + iarray ! array containing field for which halo + + integer (int_kind) :: & + ifillValue ! fill value + + character(len=*), parameter :: subname = '(ice_HaloUpdate2DL1)' + +!----------------------------------------------------------------------- + + allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3)),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating iarray') + return + endif + + iarray = 0 + where (array) iarray = 1 + if (present(fillValue)) then + ifillValue = 0 + if (fillValue) ifillValue = 1 + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + ifillValue, tripoleOnly) + else + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + tripoleOnly=tripoleOnly) + endif + + ! tcraig, for most BCs, the mod is not needed, iarray will always be 0 or 1. + ! for linear_extrap, the bc is not a simple copy, it's a computation from neighbor + ! points. Use the mod to provide a more consistent result for linear_extrap bcs for + ! logicals. + array = .false. + where (mod(abs(iarray),2) /= 0) array = .true. + + deallocate(iarray, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating iarray') + return + endif + +!----------------------------------------------------------------------- + + end subroutine ice_HaloUpdate2DL1 + +EOFL + +fi # if intfc ne 2DL1 + +# cat all subroutines together + +cat ${file} >> ${fileall} +cat <> ${fileall} +!*********************************************************************** +EOF2 + +done # foreach intfc + + +exit -9 + + + + + + diff --git a/cicecore/cicedyn/infrastructure/comm/mpi/ice_boundary.F90 b/cicecore/cicedyn/infrastructure/comm/mpi/ice_boundary.F90 index 5a690d490..c7471402b 100644 --- a/cicecore/cicedyn/infrastructure/comm/mpi/ice_boundary.F90 +++ b/cicecore/cicedyn/infrastructure/comm/mpi/ice_boundary.F90 @@ -12,6 +12,10 @@ module ice_boundary ! fixes for non-existent blocks ! 2008-01-28: Elizabeth Hunke replaced old routines with new POP ! infrastructure +! 2026-02-16: T Craig refactored and added zero_gradient and linear_extrap +! boundary conditions. ice_HaloUpdate routines +! generated by code generation script and made +! fully compatible with use in serial version. ! !----------------------------------------------------------------------- ! @@ -49,11 +53,14 @@ module ice_boundary ! !----------------------------------------------------------------------- - +#ifndef SERIAL_REMOVE_MPI use mpi ! MPI Fortran module + use ice_communicate, only: mpiR4, mpiR8, mpitagHalo +#endif + use ice_kinds_mod - use ice_communicate, only: my_task, mpiR4, mpiR8, mpitagHalo - use ice_constants, only: field_type_scalar, & + use ice_communicate, only: my_task + use ice_constants, only: c0, c1, field_type_scalar, & field_type_vector, field_type_angle, & field_type_unknown, field_type_noupdate, & field_loc_center, field_loc_NEcorner, & @@ -61,6 +68,7 @@ module ice_boundary field_loc_unknown, field_loc_noupdate use ice_global_reductions, only: global_maxval use ice_exit, only: abort_ice + use ice_fileunits, only: nu_diag use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted use ice_blocks, only: nx_block, ny_block, nghost, & @@ -81,8 +89,6 @@ module ice_boundary integer (int_kind) :: & communicator, &! communicator to use for update messages numLocalBlocks, &! number of local blocks, needed for halo fill - numMsgSend, &! number of messages to send halo update - numMsgRecv, &! number of messages to recv halo update numLocalCopies, &! num local copies for halo update tripoleRows ! number of rows in tripole buffer @@ -90,7 +96,22 @@ module ice_boundary tripoleTFlag ! NS boundary is a tripole T-fold integer (int_kind), dimension(:), pointer :: & - blockGlobalID, &! list of local block global IDs, needed for halo fill + blockGlobalID ! list of local block global IDs, needed for halo fill + + integer (int_kind), dimension(:,:), pointer :: & + srcLocalAddr, &! src addresses for each local copy + dstLocalAddr ! dst addresses for each local copy + + character (char_len) :: & + nsBoundaryType, &! type of boundary to use in logical ns dir + ewBoundaryType ! type of boundary to use in logical ew dir + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + numMsgSend, &! number of messages to send halo update + numMsgRecv ! number of messages to recv halo update + + integer (int_kind), dimension(:), pointer :: & recvTask, &! task from which to recv each msg sendTask, &! task to which to send each msg sizeSend, &! size of each sent message @@ -98,18 +119,10 @@ module ice_boundary tripSend, &! send msg tripole flag, 0=non-zipper block tripRecv ! recv msg tripole flag, for masked halos - integer (int_kind), dimension(:,:), pointer :: & - srcLocalAddr, &! src addresses for each local copy - dstLocalAddr ! dst addresses for each local copy - integer (int_kind), dimension(:,:,:), pointer :: & sendAddr, &! src addresses for each sent message recvAddr ! dst addresses for each recvd message - - character (char_len) :: & - nsBoundaryType, &! type of boundary to use in logical ns dir - ewBoundaryType ! type of boundary to use in logical ew dir - +#endif end type public :: ice_HaloCreate, & @@ -140,42 +153,14 @@ module ice_boundary !----------------------------------------------------------------------- ! -! to prevent frequent allocate-deallocate for 2d halo updates, create -! a static 2d buffer to be allocated once at creation. if future -! creation needs larger buffer, resize during the creation. -! -!----------------------------------------------------------------------- - - integer (int_kind), public :: & - bufSizeSend, &! max buffer size for send messages - bufSizeRecv ! max buffer size for recv messages - - integer (int_kind), dimension(:,:), allocatable, public :: & - bufSendI4, &! buffer for use to send in 2D i4 halo updates - bufRecvI4 ! buffer for use to recv in 2D i4 halo updates - - real (real_kind), dimension(:,:), allocatable, public :: & - bufSendR4, &! buffer for use to send in 2D r4 halo updates - bufRecvR4 ! buffer for use to recv in 2D r4 halo updates - - real (dbl_kind), dimension(:,:), allocatable, public :: & - bufSendR8, &! buffer for use to send in 2D r8 halo updates - bufRecvR8 ! buffer for use to recv in 2D r8 halo updates - -!----------------------------------------------------------------------- -! -! global buffers for tripole boundary +! Buffer size place holders ! !----------------------------------------------------------------------- - integer (int_kind), dimension(:,:), allocatable, public :: & - bufTripoleI4 - - real (real_kind), dimension(:,:), allocatable, public :: & - bufTripoleR4 - - real (dbl_kind), dimension(:,:), allocatable, public :: & - bufTripoleR8 + integer (int_kind) :: & + bufSizeSend = -1, &! max buffer size for send messages + bufSizeRecv = -1, &! max buffer size for recv messages + nxGlobal_size = -1 ! global tripole boundary size !*********************************************************************** @@ -220,9 +205,9 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & seBlock, swBlock, &! block id southeast, southwest nbrs srcProc, dstProc, &! source, dest processor locations srcLocalID, dstLocalID, &! local block index of src,dst blocks - maxTmp, &! temp for global maxval blockSizeX, &! size of default physical domain in X blockSizeY, &! size of default physical domain in Y + maxTmp, &! temp for global maxval maxSizeSend, maxSizeRecv, &! max buffer sizes numMsgSend, numMsgRecv, &! number of messages for this halo eastMsgSize, westMsgSize, &! nominal sizes for e-w msgs @@ -236,7 +221,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & sendCount, recvCount ! count number of words to each proc logical (log_kind) :: & - resize, &! flag for resizing buffers tripoleBlock, &! flag for identifying north tripole blocks tripoleTFlag ! flag for processing tripole buffer as T-fold @@ -270,29 +254,20 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** store some block info to fill haloes properly call ice_distributionGet(dist, numLocalBlocks=halo%numLocalBlocks) - allocate(halo%blockGlobalID(halo%numLocalBlocks)) if (halo%numLocalBlocks > 0) then + allocate(halo%blockGlobalID(halo%numLocalBlocks),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating halo%blockGlobalID') + return + endif call ice_distributionGet(dist, blockGlobalID=halo%blockGlobalID) endif if (nsBoundaryType == 'tripole' .or. nsBoundaryType == 'tripoleT') then tripoleTFlag = (nsBoundaryType == 'tripoleT') if (tripoleTflag) tripoleRows = tripoleRows+1 - - !*** allocate tripole message buffers if not already done - - if (.not. allocated(bufTripoleR8)) then - allocate (bufTripoleI4(nxGlobal, tripoleRows), & - bufTripoleR4(nxGlobal, tripoleRows), & - bufTripoleR8(nxGlobal, tripoleRows), & - stat=istat) - - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating tripole buffers') - return - endif - endif - + !*** set tripole message size if not already done + if (nxGlobal_size < 0) nxGlobal_size = nxGlobal else tripoleTFlag = .false. endif @@ -401,7 +376,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** if a tripole boundary block, non-local east neighbor !*** needs a chunk of the north boundary, so add a message !*** for that - if (tripoleBlock .and. dstProc /= srcProc) then call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, dstProc, tripoleMsgSize) @@ -426,7 +400,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** if a tripole boundary block, non-local west neighbor !*** needs a chunk of the north boundary, so add a message !*** for that - if (tripoleBlock .and. dstProc /= srcProc) then call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, dstProc, tripoleMsgSize) @@ -442,7 +415,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_distributionGetBlockLoc(dist, neBlock, dstProc, & dstLocalID) - else if (neBlock < 0) then ! tripole north row msgSize = tripoleMsgSize ! tripole needs whole top row of block @@ -466,7 +438,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_distributionGetBlockLoc(dist, nwBlock, dstProc, & dstLocalID) - else if (nwBlock < 0) then ! tripole north row, count block msgSize = tripoleMsgSize ! tripole NE corner update - entire row needed @@ -513,9 +484,11 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, dstProc, cornerMsgSize) +#ifndef SERIAL_REMOVE_MPI !*** for tripole grids with padded domain, padding will !*** prevent tripole buffer from getting all the info !*** it needs - must extend footprint at top boundary + !*** Only needed for multi-proc configurations if (tripoleBlock .and. & !tripole mod(nxGlobal,blockSizeX) /= 0) then !padding @@ -597,6 +570,7 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & endif endif +#endif end do msgCountLoop @@ -612,6 +586,19 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & sendCount(my_task+1) = 0 recvCount(my_task+1) = 0 + allocate(halo%srcLocalAddr(3,halo%numLocalCopies), & + halo%dstLocalAddr(3,halo%numLocalCopies), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating LocalAddr arrays') + return + endif + + halo%srcLocalAddr = 0 + halo%dstLocalAddr = 0 + +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! now count the number of actual messages to be sent and received @@ -636,63 +623,8 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & maxTmp = maxval(recvCount) maxSizeRecv = global_maxval(maxTmp, dist) - if (.not. allocated(bufSendR8)) then - - bufSizeSend = maxSizeSend - bufSizeRecv = maxSizeRecv - - allocate(bufSendI4(bufSizeSend, numMsgSend), & - bufRecvI4(bufSizeRecv, numMsgRecv), & - bufSendR4(bufSizeSend, numMsgSend), & - bufRecvR4(bufSizeRecv, numMsgRecv), & - bufSendR8(bufSizeSend, numMsgSend), & - bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat) - - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating 2d buffers') - return - endif - - else - - resize = .false. - - if (maxSizeSend > bufSizeSend) then - resize = .true. - bufSizeSend = maxSizeSend - endif - if (maxSizeRecv > bufSizeRecv) then - resize = .true. - bufSizeRecv = maxSizeRecv - endif - - if (numMsgSend > size(bufSendR8,dim=2)) resize = .true. - if (numMsgRecv > size(bufRecvR8,dim=2)) resize = .true. - - if (resize) then - deallocate(bufSendI4, bufRecvI4, bufSendR4, & - bufRecvR4, bufSendR8, bufRecvR8, stat=istat) - - if (istat > 0) then - call abort_ice(subname//'ERROR: deallocating 2d buffers') - return - endif - - allocate(bufSendI4(bufSizeSend, numMsgSend), & - bufRecvI4(bufSizeRecv, numMsgRecv), & - bufSendR4(bufSizeSend, numMsgSend), & - bufRecvR4(bufSizeRecv, numMsgRecv), & - bufSendR8(bufSizeSend, numMsgSend), & - bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat) - - if (istat > 0) then - call abort_ice(subname//'ERROR: reallocating 2d buffers') - return - endif - - endif - - endif + bufSizeSend = max(bufSizeSend,maxSizeSend) + bufSizeRecv = max(bufSizeRecv,maxSizeRecv) !----------------------------------------------------------------------- ! @@ -708,15 +640,8 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & halo%tripRecv(numMsgRecv), & halo%sendAddr(3,bufSizeSend,numMsgSend), & halo%recvAddr(3,bufSizeRecv,numMsgRecv), & - halo%srcLocalAddr(3,halo%numLocalCopies), & - halo%dstLocalAddr(3,halo%numLocalCopies), & stat = istat) - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating halo message info arrays') - return - endif - halo%sendTask = 0 halo%recvTask = 0 halo%sizeSend = 0 @@ -725,8 +650,9 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & halo%tripRecv = 0 halo%sendAddr = 0 halo%recvAddr = 0 - halo%srcLocalAddr = 0 - halo%dstLocalAddr = 0 + halo%numMsgSend = 0 + halo%numMsgRecv = 0 +#endif deallocate(sendCount, recvCount, stat=istat) @@ -744,8 +670,6 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** reset halo scalars to use as counters - halo%numMsgSend = 0 - halo%numMsgRecv = 0 halo%numLocalCopies = 0 msgConfigLoop: do iblock=1,nblocks_tot @@ -773,24 +697,18 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & dstLocalID = 0 endif - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - northBlock, dstProc, dstLocalID, & - 'north') + call ice_HaloMsgCreate(halo, dist, iblock, northBlock, 'north') !*** if a tripole boundary block, also create a local !*** message into and out of tripole buffer if (tripoleBlock) then !*** copy out of tripole buffer - includes halo - call ice_HaloMsgCreate(halo,-iblock, srcProc, srcLocalID, & - iblock, srcProc, srcLocalID, & - 'north') + call ice_HaloMsgCreate(halo, dist,-iblock, iblock, 'north') !*** copy in only required if dstProc not same as srcProc if (dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - -iblock, srcProc, srcLocalID, & - 'north') + call ice_HaloMsgCreate(halo, dist, iblock, -iblock, 'north') endif endif @@ -799,19 +717,7 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, & ewBoundaryType, nsBoundaryType) - - if (southBlock > 0) then - call ice_distributionGetBlockLoc(dist, southBlock, dstProc, & - dstLocalID) - - else - dstProc = 0 - dstLocalID = 0 - endif - - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - southBlock, dstProc, dstLocalID, & - 'south') + call ice_HaloMsgCreate(halo, dist, iblock, southBlock, 'south') !*** find east neighbor block and add to message count @@ -821,25 +727,19 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & if (eastBlock > 0) then call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, & dstLocalID) - else dstProc = 0 dstLocalID = 0 endif - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - eastBlock, dstProc, dstLocalID, & - 'east') + call ice_HaloMsgCreate(halo, dist, iblock, eastBlock, 'east') !*** if a tripole boundary block, non-local east neighbor !*** needs a chunk of the north boundary, so add a message !*** for that if (tripoleBlock .and. dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - -eastBlock, dstProc, dstLocalID, & - 'north') - + call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north') endif !*** find west neighbor block and add to message count @@ -850,103 +750,50 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & if (westBlock > 0) then call ice_distributionGetBlockLoc(dist, westBlock, dstProc, & dstLocalID) - else dstProc = 0 dstLocalID = 0 endif - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - westBlock, dstProc, dstLocalID, & - 'west') - + call ice_HaloMsgCreate(halo, dist, iblock, westBlock, 'west') !*** if a tripole boundary block, non-local west neighbor !*** needs a chunk of the north boundary, so add a message !*** for that if (tripoleBlock .and. dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - -westBlock, dstProc, dstLocalID, & - 'north') - + call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north') endif !*** find northeast neighbor block and add to message count neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, & ewBoundaryType, nsBoundaryType) - - if (neBlock /= 0) then - call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, & - dstLocalID) - - else - dstProc = 0 - dstLocalID = 0 - endif - - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - neBlock, dstProc, dstLocalID, & - 'northeast') + call ice_HaloMsgCreate(halo, dist, iblock, neBlock, 'northeast') !*** find northwest neighbor block and add to message count nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, & ewBoundaryType, nsBoundaryType) - - if (nwBlock /= 0) then - call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, & - dstLocalID) - - else - dstProc = 0 - dstLocalID = 0 - endif - - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - nwBlock, dstProc, dstLocalID, & - 'northwest') + call ice_HaloMsgCreate(halo, dist, iblock, nwBlock, 'northwest') !*** find southeast neighbor block and add to message count seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, & ewBoundaryType, nsBoundaryType) - - if (seBlock > 0) then - call ice_distributionGetBlockLoc(dist, seBlock, dstProc, & - dstLocalID) - - else - dstProc = 0 - dstLocalID = 0 - endif - - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - seBlock, dstProc, dstLocalID, & - 'southeast') + call ice_HaloMsgCreate(halo, dist, iblock, seBlock, 'southeast') !*** find southwest neighbor block and add to message count swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, & ewBoundaryType, nsBoundaryType) + call ice_HaloMsgCreate(halo, dist, iblock, swBlock, 'southwest') - if (swBlock > 0) then - call ice_distributionGetBlockLoc(dist, swBlock, dstProc, & - dstLocalID) - - else - dstProc = 0 - dstLocalID = 0 - endif - - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - swBlock, dstProc, dstLocalID, & - 'southwest') - +#ifndef SERIAL_REMOVE_MPI !*** for tripole grids with padded domain, padding will !*** prevent tripole buffer from getting all the info !*** it needs - must extend footprint at top boundary + !*** Only needed for multi-proc configurations if (tripoleBlock .and. & !tripole mod(nxGlobal,blockSizeX) /= 0) then !padding @@ -966,10 +813,7 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & endif if (dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - -eastBlock, dstProc, dstLocalID, & - 'north') - + call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north') endif !*** find EastNorthEast neighbor block and add to message count @@ -989,9 +833,7 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & endif if (dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - neBlock, dstProc, dstLocalID, & - 'north') + call ice_HaloMsgCreate(halo, dist, iblock, neBlock, 'north') endif !*** find west2 neighbor block and add to message count @@ -1009,10 +851,7 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & endif if (dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - -westBlock, dstProc, dstLocalID, & - 'north') - + call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north') endif !*** find WestNorthWest neighbor block and add to message count @@ -1032,13 +871,12 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & endif if (dstProc /= srcProc) then - call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, & - nwBlock, dstProc, dstLocalID, & - 'north') + call ice_HaloMsgCreate(halo, dist, iblock, nwBlock, 'north') endif endif +#endif end do msgConfigLoop @@ -1057,13 +895,12 @@ subroutine ice_HaloMask(halo, basehalo, mask) use ice_domain_size, only: max_blocks type (ice_halo) :: & - basehalo ! basehalo to mask + basehalo ! basehalo to mask integer (int_kind), intent(in) :: & mask(nx_block,ny_block,max_blocks) ! mask of live points type (ice_halo) :: & halo ! a new halo type with info for halo updates - character(len=*), parameter :: subname = '(ice_HaloMask)' !----------------------------------------------------------------------- ! @@ -1071,66 +908,89 @@ subroutine ice_HaloMask(halo, basehalo, mask) ! !----------------------------------------------------------------------- - integer (int_kind) :: & - n,nmsg,scnt, &! counters - icel,jcel,nblock, &! gridcell index - istat, &! allocate status flag - communicator, &! communicator for message passing - numMsgSend, numMsgRecv, &! number of messages for this halo - numLocalCopies, &! num local copies for halo update - numLocalBlocks, &! num local blocks for halo fill - tripoleRows, &! number of rows in tripole buffer - lbufSizeSend, &! buffer size for send messages - lbufSizeRecv ! buffer size for recv messages + integer (int_kind) :: & + istat, &! allocate status flag + communicator, &! communicator for message passing + numLocalCopies, &! num local copies for halo update + numLocalBlocks, &! num local blocks for halo fill + tripoleRows ! number of rows in tripole buffer + logical (log_kind) :: & - tripoleTFlag, & ! flag for processing tripole buffer as T-fold - tmpflag ! temporary flag for setting halomask along T-fold + tripoleTFlag, &! flag for processing tripole buffer as T-fold + tmpflag ! temporary flag for setting halomask along T-fold + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + n,nmsg,scnt, &! counters + icel,jcel,nblock, &! gridcell index + numMsgSend, numMsgRecv, &! number of messages for this halo + lbufSizeSend, &! buffer size for send messages + lbufSizeRecv ! buffer size for recv messages +#endif + + character(len=*), parameter :: subname = '(ice_HaloMask)' !----------------------------------------------------------------------- ! ! allocate and initialize halo -! always keep tripole zipper msgs -! -!----------------------------------------------------------------------- - - communicator = basehalo%communicator - tripoleRows = basehalo%tripoleRows - tripoleTFlag = basehalo%tripoleTFlag - numMsgSend = basehalo%numMsgSend - numMsgRecv = basehalo%numMsgRecv - numLocalCopies = basehalo%numLocalCopies - numLocalBlocks = basehalo%numLocalBlocks - lbufSizeSend = size(basehalo%sendAddr,dim=2) - lbufSizeRecv = size(basehalo%recvAddr,dim=2) - - allocate(halo%sendTask(numMsgSend), & - halo%recvTask(numMsgRecv), & - halo%sizeSend(numMsgSend), & - halo%sizeRecv(numMsgRecv), & - halo%tripSend(numMsgSend), & - halo%tripRecv(numMsgRecv), & - halo%sendAddr(3,lbufSizeSend,numMsgSend), & - halo%recvAddr(3,lbufSizeRecv,numMsgRecv), & - halo%srcLocalAddr(3,numLocalCopies), & - halo%dstLocalAddr(3,numLocalCopies), & - halo%blockGlobalID(numLocalBlocks), & - stat = istat) +! halos are not masked for local copies +! +!----------------------------------------------------------------------- - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating halo message info arrays') - return - endif + communicator = basehalo%communicator + tripoleRows = basehalo%tripoleRows + tripoleTFlag = basehalo%tripoleTFlag + numLocalCopies = basehalo%numLocalCopies + numLocalBlocks = basehalo%numLocalBlocks + + allocate(halo%srcLocalAddr(3,numLocalCopies), & + halo%dstLocalAddr(3,numLocalCopies), & + halo%blockGlobalID(numLocalBlocks), & + stat = istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating src,dst LocalAddr arrays') + return + endif + + halo%communicator = communicator + halo%tripoleRows = tripoleRows + halo%tripoleTFlag = tripoleTFlag + halo%numLocalCopies = numLocalCopies + halo%numLocalBlocks = numLocalBlocks + + halo%srcLocalAddr = basehalo%srcLocalAddr(:,1:numLocalCopies) + halo%dstLocalAddr = basehalo%dstLocalAddr(:,1:numLocalCopies) + + halo%blockGlobalID = basehalo%blockGlobalID + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! mask communication part of halo +! always keep tripole zipper msgs! +! +!----------------------------------------------------------------------- - halo%communicator = communicator - halo%tripoleRows = tripoleRows - halo%tripoleTFlag = tripoleTFlag - halo%numLocalCopies = numLocalCopies - halo%numLocalBlocks = numLocalBlocks + numMsgSend = basehalo%numMsgSend + numMsgRecv = basehalo%numMsgRecv + lbufSizeSend = size(basehalo%sendAddr,dim=2) + lbufSizeRecv = size(basehalo%recvAddr,dim=2) - halo%srcLocalAddr = basehalo%srcLocalAddr(:,1:numLocalCopies) - halo%dstLocalAddr = basehalo%dstLocalAddr(:,1:numLocalCopies) + allocate(halo%sendTask(numMsgSend), & + halo%recvTask(numMsgRecv), & + halo%sizeSend(numMsgSend), & + halo%sizeRecv(numMsgRecv), & + halo%tripSend(numMsgSend), & + halo%tripRecv(numMsgRecv), & + halo%sendAddr(3,lbufSizeSend,numMsgSend), & + halo%recvAddr(3,lbufSizeRecv,numMsgRecv), & + stat = istat) - halo%blockGlobalID = basehalo%blockGlobalID + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating halo send,recv arrays') + return + endif numMsgSend = 0 do nmsg=1,basehalo%numMsgSend @@ -1195,6 +1055,7 @@ subroutine ice_HaloMask(halo, basehalo, mask) enddo enddo halo%numMsgRecv = numMsgRecv +#endif !----------------------------------------------------------------------- @@ -1202,14 +1063,18 @@ end subroutine ice_HaloMask !*********************************************************************** - subroutine ice_HaloUpdate2DR8(array, halo, & + subroutine ice_HaloUpdate2DR8(array, halo, & fieldLoc, fieldKind, & fillValue, tripoleOnly) +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. + ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -1227,10 +1092,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ! closed boundaries) logical (log_kind), intent(in), optional :: & - tripoleOnly ! optional flag to execute halo only across tripole seam. - ! this is required for a few fields where we just want to - ! ensure the tripole seam is synced up to preserve symmetry. - ! Added June, 2022 by tcraig. Only added to 2DR8 for now. + tripoleOnly ! optional flag to execute halo only across tripole seam real (dbl_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo @@ -1243,36 +1105,47 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter, &! fill outer boundary ns - ltripoleOnly ! local tripoleOnly value + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (dbl_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of messages + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DR8)' @@ -1299,14 +1172,14 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -1314,7 +1187,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind endif if (present(tripoleOnly)) then @@ -1323,28 +1196,47 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ltripoleOnly = .false. endif + nz = 1 + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - bufTripoleR8 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + !----------------------------------------------------------------------- ! ! post receives @@ -1352,11 +1244,10 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg) - call MPI_IRECV(bufRecvR8(1,nmsg), len, mpiR8, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -1367,28 +1258,35 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - + i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) - bufSendR8(n,nmsg) = array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do end do - do n=halo%sizeSend(nmsg)+1,bufSizeSend - bufSendR8(n,nmsg) = fill ! fill remainder of buffer + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg) - call MPI_ISEND(bufSendR8(1,nmsg), len, mpiR8, & - halo%sendTask(nmsg), & - mpitagHalo + my_task, & + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! -! While messages are being communicated, fill out halo region +! while messages are being communicated, fill out halo region ! needed for masked halos to ensure halo values are filled for ! halo grid cells that are not updated except in cases where ! you don't want to overwrite those halos @@ -1408,29 +1306,29 @@ subroutine ice_HaloUpdate2DR8(array, halo, & iblock=iblock, jblock=jblock) if (ewfillouter .or. iblock > 1) then ! west edge do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill + array(ilo-i,jlo:jhi,iblk) = fill enddo endif if (ewfillouter .or. iblock < nblocks_x) then ! east edge do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill + array(ihi+i,jlo:jhi,iblk) = fill enddo endif if (nsfillouter .or. jblock > 1) then ! south edge do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill + array(ilo:ihi,jlo-j,iblk) = fill enddo endif if (nsfillouter .or. jblock < nblocks_y) then ! north edge do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill + array(ilo:ihi,jhi+j,iblk) = fill enddo endif if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner (nsfillouter .or. jblock > 1)) then do j = 1,nghost do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill + array(ilo-i,jlo-j,iblk) = fill enddo enddo endif @@ -1438,7 +1336,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock < nblocks_y)) then do j = 1,nghost do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill + array(ilo-i,jhi+j,iblk) = fill enddo enddo endif @@ -1446,7 +1344,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock > 1)) then do j = 1,nghost do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill + array(ihi+i,jlo-j,iblk) = fill enddo enddo endif @@ -1454,12 +1352,12 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock < nblocks_y)) then do j = 1,nghost do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill + array(ihi+i,jhi+j,iblk) = fill enddo enddo endif enddo ! iblk - endif + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -1479,28 +1377,38 @@ subroutine ice_HaloUpdate2DR8(array, halo, & jDst = halo%dstLocalAddr(2,nmsg) dstBlock = halo%dstLocalAddr(3,nmsg) - if (ltripoleOnly) then - if (srcBlock > 0) then - if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do endif - else - if (srcBlock > 0) then - if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) - else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) - endif - else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -1511,24 +1419,125 @@ subroutine ice_HaloUpdate2DR8(array, halo, & call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) do nmsg=1,halo%numMsgRecv + i = 0 do n=1,halo%sizeRecv(nmsg) iDst = halo%recvAddr(1,n,nmsg) jDst = halo%recvAddr(2,n,nmsg) dstBlock = halo%recvAddr(3,n,nmsg) - if (ltripoleOnly) then - if (dstBlock < 0) then !tripole - bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg) - endif - else - if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = bufRecvR8(n,nmsg) - else if (dstBlock < 0) then !tripole - bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg) + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -1562,13 +1571,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -1584,13 +1597,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -1618,13 +1635,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -1640,13 +1661,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -1686,7 +1711,11 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -1694,6 +1723,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -1702,27 +1732,47 @@ subroutine ice_HaloUpdate2DR8(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DR8 !*********************************************************************** - subroutine ice_HaloUpdate2DR4(array, halo, & + subroutine ice_HaloUpdate2DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -1739,6 +1789,9 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -1750,35 +1803,47 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (real_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message - integer (int_kind) :: len ! length of messages + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DR4)' @@ -1805,14 +1870,14 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -1820,31 +1885,56 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind endif + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. + endif + + nz = 1 + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR4)) then - nxGlobal = size(bufTripoleR4,dim=1) - bufTripoleR4 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + !----------------------------------------------------------------------- ! ! post receives @@ -1852,11 +1942,10 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg) - call MPI_IRECV(bufRecvR4(1,nmsg), len, mpiR4, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -1867,24 +1956,31 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - + i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) - bufSendR4(n,nmsg) = array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do end do - do n=halo%sizeSend(nmsg)+1,bufSizeSend - bufSendR4(n,nmsg) = fill ! fill remainder of buffer + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg) - call MPI_ISEND(bufSendR4(1,nmsg), len, mpiR4, & - halo%sendTask(nmsg), & - mpitagHalo + my_task, & + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -1895,66 +1991,71 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -1976,17 +2077,36 @@ subroutine ice_HaloUpdate2DR4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR4(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do endif else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -1997,18 +2117,125 @@ subroutine ice_HaloUpdate2DR4(array, halo, & call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) do nmsg=1,halo%numMsgRecv + i = 0 do n=1,halo%sizeRecv(nmsg) iDst = halo%recvAddr(1,n,nmsg) jDst = halo%recvAddr(2,n,nmsg) dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = bufRecvR4(n,nmsg) + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole - bufTripoleR4(iDst,jDst) = bufRecvR4(n,nmsg) + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -2042,13 +2269,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -2064,13 +2295,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -2098,13 +2333,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -2120,13 +2359,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -2166,7 +2409,11 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -2174,6 +2421,7 @@ subroutine ice_HaloUpdate2DR4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -2182,27 +2430,47 @@ subroutine ice_HaloUpdate2DR4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DR4 !*********************************************************************** - subroutine ice_HaloUpdate2DI4(array, halo, & + subroutine ice_HaloUpdate2DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal integer arrays. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -2219,6 +2487,9 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -2230,35 +2501,47 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids + integer (int_kind) :: & + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + logical (log_kind) :: & + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + integer (int_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer +#ifndef SERIAL_REMOVE_MPI integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + ierr, &! error or status flag for MPI,alloc + len ! length of message - logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of messages + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DI4)' @@ -2285,14 +2568,14 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -2300,31 +2583,56 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = 1 + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleI4)) then - nxGlobal = size(bufTripoleI4,dim=1) - bufTripoleI4 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + !----------------------------------------------------------------------- ! ! post receives @@ -2332,11 +2640,10 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg) - call MPI_IRECV(bufRecvI4(1,nmsg), len, MPI_INTEGER, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -2347,24 +2654,31 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - + i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) - bufSendI4(n,nmsg) = array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do end do - do n=halo%sizeSend(nmsg)+1,bufSizeSend - bufSendI4(n,nmsg) = fill ! fill remainder of buffer + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg) - call MPI_ISEND(bufSendI4(1,nmsg), len, MPI_INTEGER, & - halo%sendTask(nmsg), & - mpitagHalo + my_task, & + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -2375,66 +2689,71 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -2456,17 +2775,36 @@ subroutine ice_HaloUpdate2DI4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleI4(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do endif else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -2477,18 +2815,125 @@ subroutine ice_HaloUpdate2DI4(array, halo, & call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) do nmsg=1,halo%numMsgRecv + i = 0 do n=1,halo%sizeRecv(nmsg) iDst = halo%recvAddr(1,n,nmsg) jDst = halo%recvAddr(2,n,nmsg) dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = bufRecvI4(n,nmsg) + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole - bufTripoleI4(iDst,jDst) = bufRecvI4(n,nmsg) + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -2522,13 +2967,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -2544,13 +2993,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -2578,13 +3031,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -2600,13 +3057,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -2646,7 +3107,11 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -2654,6 +3119,7 @@ subroutine ice_HaloUpdate2DI4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -2662,22 +3128,38 @@ subroutine ice_HaloUpdate2DI4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DI4 !*********************************************************************** - subroutine ice_HaloUpdate2DL1(array, halo, & + subroutine ice_HaloUpdate2DL1(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface @@ -2693,12 +3175,15 @@ subroutine ice_HaloUpdate2DL1(array, halo, & fieldLoc ! id for location on horizontal grid ! (center, NEcorner, Nface, Eface) - integer (int_kind), intent(in), optional :: & + logical (log_kind), intent(in), optional :: & fillValue ! optional value to put in ghost cells ! where neighbor points are unknown ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + logical (log_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -2709,45 +3194,51 @@ subroutine ice_HaloUpdate2DL1(array, halo, & ! !----------------------------------------------------------------------- + integer (int_kind) :: & + istat ! allocate return status + integer (int_kind), dimension(:,:,:), allocatable :: & - iarray ! integer array for logical + iarray ! array containing field for which halo + + integer (int_kind) :: & + ifillValue ! fill value character(len=*), parameter :: subname = '(ice_HaloUpdate2DL1)' !----------------------------------------------------------------------- -! -! abort or return on unknown or noupdate field_loc or field_type -! -!----------------------------------------------------------------------- - - if (fieldLoc == field_loc_unknown .or. & - fieldKind == field_type_unknown) then - call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed') - return - endif - if (fieldLoc == field_loc_noupdate .or. & - fieldKind == field_type_noupdate) then + allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3)),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating iarray') return endif -!----------------------------------------------------------------------- -! -! copy logical into integer array and call haloupdate on integer array -! -!----------------------------------------------------------------------- - - allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3))) - iarray(:,:,:) = 0 + iarray = 0 where (array) iarray = 1 + if (present(fillValue)) then + ifillValue = 0 + if (fillValue) ifillValue = 1 + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + ifillValue, tripoleOnly) + else + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + tripoleOnly=tripoleOnly) + endif - call ice_HaloUpdate(iarray, halo, & - fieldLoc, fieldKind, & - fillValue) - + ! tcraig, for most BCs, the mod is not needed, iarray will always be 0 or 1. + ! for linear_extrap, the bc is not a simple copy, it's a computation from neighbor + ! points. Use the mod to provide a more consistent result for linear_extrap bcs for + ! logicals. array = .false. - where (iarray /= 0) array = .true. - deallocate(iarray) + where (mod(abs(iarray),2) /= 0) array = .true. + + deallocate(iarray, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating iarray') + return + endif !----------------------------------------------------------------------- @@ -2755,14 +3246,18 @@ end subroutine ice_HaloUpdate2DL1 !*********************************************************************** - subroutine ice_HaloUpdate3DR8(array, halo, & + subroutine ice_HaloUpdate3DR8(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -2779,6 +3274,9 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (dbl_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -2790,42 +3288,47 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam - real (dbl_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 3d send,recv buffers + real (dbl_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids - real (dbl_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of message + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DR8)' @@ -2852,14 +3355,14 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -2867,48 +3370,56 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = size(array, dim=3) + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 3D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - - allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), & - bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz), & - stat=ierr) + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -2916,11 +3427,10 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg)*nz - call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -2931,28 +3441,31 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) + do l=1,nt do k=1,nz i = i + 1 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) end do + end do end do - do n=i+1,bufSizeSend*nz + + do n=i+1,bufSizeSend*nz*nt bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg)*nz + len = halo%SizeSend(nmsg)*nz*nt call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & halo%sendTask(nmsg), & mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -2963,66 +3476,71 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -3044,23 +3562,36 @@ subroutine ice_HaloUpdate3DR8(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -3078,18 +3609,118 @@ subroutine ice_HaloUpdate3DR8(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do k=1,nz - i = i + 1 - array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole + do l=1,nt do k=1,nz i = i + 1 - bufTripole(iDst,jDst,k) = bufRecv(i,nmsg) + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -3123,14 +3754,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3147,14 +3780,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3183,14 +3818,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3207,14 +3844,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3255,9 +3894,10 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -3266,6 +3906,7 @@ subroutine ice_HaloUpdate3DR8(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -3274,19 +3915,28 @@ subroutine ice_HaloUpdate3DR8(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 3d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -3294,14 +3944,18 @@ end subroutine ice_HaloUpdate3DR8 !*********************************************************************** - subroutine ice_HaloUpdate3DR4(array, halo, & + subroutine ice_HaloUpdate3DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -3318,6 +3972,9 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -3329,42 +3986,47 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (real_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message - real (real_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 3d send,recv buffers + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids - real (real_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of message + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DR4)' @@ -3391,14 +4053,14 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -3406,48 +4068,56 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = size(array, dim=3) + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 3D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - - allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), & - bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz), & - stat=ierr) + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -3455,11 +4125,10 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg)*nz - call MPI_IRECV(bufRecv(1,nmsg), len, mpiR4, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -3470,28 +4139,31 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) + do l=1,nt do k=1,nz i = i + 1 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) end do + end do end do - do n=i+1,bufSizeSend*nz + + do n=i+1,bufSizeSend*nz*nt bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg)*nz - call MPI_ISEND(bufSend(1,nmsg), len, mpiR4, & + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & halo%sendTask(nmsg), & mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -3502,66 +4174,71 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -3583,23 +4260,36 @@ subroutine ice_HaloUpdate3DR4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -3617,18 +4307,118 @@ subroutine ice_HaloUpdate3DR4(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do k=1,nz - i = i + 1 - array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole + do l=1,nt do k=1,nz i = i + 1 - bufTripole(iDst,jDst,k) = bufRecv(i,nmsg) + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -3662,14 +4452,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3686,14 +4478,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3722,14 +4516,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3746,14 +4542,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3794,9 +4592,10 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -3805,6 +4604,7 @@ subroutine ice_HaloUpdate3DR4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -3813,19 +4613,28 @@ subroutine ice_HaloUpdate3DR4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 3d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -3833,14 +4642,18 @@ end subroutine ice_HaloUpdate3DR4 !*********************************************************************** - subroutine ice_HaloUpdate3DI4(array, halo, & + subroutine ice_HaloUpdate3DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -3857,6 +4670,9 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -3868,42 +4684,47 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids + integer (int_kind) :: & + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + logical (log_kind) :: & + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + integer (int_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer +#ifndef SERIAL_REMOVE_MPI integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + ierr, &! error or status flag for MPI,alloc + len ! length of message - logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids integer (int_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 3d send,recv buffers - - integer (int_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of message + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DI4)' @@ -3930,14 +4751,14 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -3945,48 +4766,56 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = size(array, dim=3) + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 3D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - - allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), & - bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz), & - stat=ierr) + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -3994,11 +4823,10 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - - len = halo%SizeRecv(nmsg)*nz - call MPI_IRECV(bufRecv(1,nmsg), len, MPI_INTEGER, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -4009,28 +4837,31 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) + do l=1,nt do k=1,nz i = i + 1 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) end do + end do end do - do n=i+1,bufSizeSend*nz + + do n=i+1,bufSizeSend*nz*nt bufSend(n,nmsg) = fill ! fill remainder of buffer end do - len = halo%SizeSend(nmsg)*nz - call MPI_ISEND(bufSend(1,nmsg), len, MPI_INTEGER, & - halo%sendTask(nmsg), & - mpitagHalo + my_task, & + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -4041,66 +4872,71 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -4122,23 +4958,36 @@ subroutine ice_HaloUpdate3DI4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -4156,18 +5005,118 @@ subroutine ice_HaloUpdate3DI4(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do k=1,nz - i = i + 1 - array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole + do l=1,nt do k=1,nz i = i + 1 - bufTripole(iDst,jDst,k) = bufRecv(i,nmsg) + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do end do endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -4201,14 +5150,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -4225,14 +5176,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -4261,14 +5214,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -4285,14 +5240,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -4333,9 +5290,10 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -4344,6 +5302,7 @@ subroutine ice_HaloUpdate3DI4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -4352,19 +5311,28 @@ subroutine ice_HaloUpdate3DI4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 3d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -4372,14 +5340,18 @@ end subroutine ice_HaloUpdate3DI4 !*********************************************************************** - subroutine ice_HaloUpdate4DR8(array, halo, & + subroutine ice_HaloUpdate4DR8(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -4396,6 +5368,9 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (dbl_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -4407,42 +5382,47 @@ subroutine ice_HaloUpdate4DR8(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,l,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns - - real (dbl_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 4d send,recv buffers + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam real (dbl_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of message + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DR8)' @@ -4469,14 +5449,14 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -4484,49 +5464,56 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = size(array, dim=3) + nt = size(array, dim=4) + nxGlobal = 0 - if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 4D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - nt = size(array, dim=4) - allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & - stat=ierr) + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -4534,7 +5521,6 @@ subroutine ice_HaloUpdate4DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - len = halo%SizeRecv(nmsg)*nz*nt call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & halo%recvTask(nmsg), & @@ -4549,7 +5535,6 @@ subroutine ice_HaloUpdate4DR8(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) @@ -4574,6 +5559,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -4584,66 +5570,71 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -4665,29 +5656,36 @@ subroutine ice_HaloUpdate4DR8(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) end do end do - else if (dstBlock < 0) then ! tripole copy into buffer + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) + array(iDst,jDst,k,l,dstBlock) = fill end do end do endif - else if (srcBlock == 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill - end do - end do endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -4705,12 +5703,17 @@ subroutine ice_HaloUpdate4DR8(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do l=1,nt - do k=1,nz - i = i + 1 - array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) - end do - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole do l=1,nt do k=1,nz @@ -4721,6 +5724,97 @@ subroutine ice_HaloUpdate4DR8(array, halo, & endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -4760,7 +5854,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal - i + 2 x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -4786,7 +5880,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -4824,7 +5918,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -4850,7 +5944,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -4896,8 +5990,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -4907,6 +6000,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -4915,19 +6009,28 @@ subroutine ice_HaloUpdate4DR8(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 4d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -4935,14 +6038,18 @@ end subroutine ice_HaloUpdate4DR8 !*********************************************************************** - subroutine ice_HaloUpdate4DR4(array, halo, & + subroutine ice_HaloUpdate4DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -4959,6 +6066,9 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -4970,42 +6080,47 @@ subroutine ice_HaloUpdate4DR4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,l,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids - - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids - - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns - - real (real_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 4d send,recv buffers + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam real (real_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of message + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DR4)' @@ -5032,14 +6147,14 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -5047,49 +6162,56 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind endif + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. + endif + + nz = size(array, dim=3) + nt = size(array, dim=4) + nxGlobal = 0 - if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 4D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - nt = size(array, dim=4) - allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & - stat=ierr) + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -5097,9 +6219,8 @@ subroutine ice_HaloUpdate4DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - len = halo%SizeRecv(nmsg)*nz*nt - call MPI_IRECV(bufRecv(1,nmsg), len, mpiR4, & + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & halo%recvTask(nmsg), & mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) @@ -5112,7 +6233,6 @@ subroutine ice_HaloUpdate4DR4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) @@ -5132,11 +6252,12 @@ subroutine ice_HaloUpdate4DR4(array, halo, & end do len = halo%SizeSend(nmsg)*nz*nt - call MPI_ISEND(bufSend(1,nmsg), len, mpiR4, & + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & halo%sendTask(nmsg), & mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -5147,66 +6268,71 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -5228,29 +6354,36 @@ subroutine ice_HaloUpdate4DR4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) end do end do - else if (dstBlock < 0) then ! tripole copy into buffer + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) + array(iDst,jDst,k,l,dstBlock) = fill end do end do endif - else if (srcBlock == 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill - end do - end do endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -5268,12 +6401,17 @@ subroutine ice_HaloUpdate4DR4(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do l=1,nt - do k=1,nz - i = i + 1 - array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) - end do - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole do l=1,nt do k=1,nz @@ -5282,8 +6420,99 @@ subroutine ice_HaloUpdate4DR4(array, halo, & end do end do endif - end do - end do + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -5323,7 +6552,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal - i + 2 x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -5349,7 +6578,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -5387,7 +6616,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -5413,7 +6642,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -5459,8 +6688,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -5470,6 +6698,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -5478,19 +6707,28 @@ subroutine ice_HaloUpdate4DR4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 4d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -5498,14 +6736,18 @@ end subroutine ice_HaloUpdate4DR4 !*********************************************************************** - subroutine ice_HaloUpdate4DI4(array, halo, & + subroutine ice_HaloUpdate4DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal integer arrays. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -5522,6 +6764,9 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -5533,42 +6778,47 @@ subroutine ice_HaloUpdate4DI4(array, halo, & !----------------------------------------------------------------------- integer (int_kind) :: & - i,j,k,l,n,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids - integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids + integer (int_kind) :: & + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts - integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags + logical (log_kind) :: & + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + ierr, &! error or status flag for MPI,alloc + len ! length of message - logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids integer (int_kind), dimension(:,:), allocatable :: & - bufSend, bufRecv ! 4d send,recv buffers + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer - - integer (int_kind) :: len ! length of messages + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DI4)' @@ -5595,14 +6845,14 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -5610,49 +6860,56 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = size(array, dim=3) + nt = size(array, dim=4) + nxGlobal = 0 - if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill + endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif -!----------------------------------------------------------------------- -! -! allocate 4D buffers -! -!----------------------------------------------------------------------- - - nz = size(array, dim=3) - nt = size(array, dim=4) - allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & - bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & - stat=ierr) + stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: allocating buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') return endif - bufTripole = fill - !----------------------------------------------------------------------- ! ! post receives @@ -5660,11 +6917,10 @@ subroutine ice_HaloUpdate4DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgRecv - len = halo%SizeRecv(nmsg)*nz*nt - call MPI_IRECV(bufRecv(1,nmsg), len, MPI_INTEGER, & - halo%recvTask(nmsg), & - mpitagHalo + halo%recvTask(nmsg), & + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) end do @@ -5675,7 +6931,6 @@ subroutine ice_HaloUpdate4DI4(array, halo, & !----------------------------------------------------------------------- do nmsg=1,halo%numMsgSend - i=0 do n=1,halo%sizeSend(nmsg) iSrc = halo%sendAddr(1,n,nmsg) @@ -5695,11 +6950,12 @@ subroutine ice_HaloUpdate4DI4(array, halo, & end do len = halo%SizeSend(nmsg)*nz*nt - call MPI_ISEND(bufSend(1,nmsg), len, MPI_INTEGER, & - halo%sendTask(nmsg), & - mpitagHalo + my_task, & + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -5710,66 +6966,71 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -5791,29 +7052,36 @@ subroutine ice_HaloUpdate4DI4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) end do end do - else if (dstBlock < 0) then ! tripole copy into buffer + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) + array(iDst,jDst,k,l,dstBlock) = fill end do end do endif - else if (srcBlock == 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill - end do - end do endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -5831,12 +7099,17 @@ subroutine ice_HaloUpdate4DI4(array, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock > 0) then - do l=1,nt - do k=1,nz - i = i + 1 - array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) - end do - end do + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif else if (dstBlock < 0) then !tripole do l=1,nt do k=1,nz @@ -5847,6 +7120,97 @@ subroutine ice_HaloUpdate4DI4(array, halo, & endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap !----------------------------------------------------------------------- ! @@ -6022,8 +7386,7 @@ subroutine ice_HaloUpdate4DI4(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -6033,6 +7396,7 @@ subroutine ice_HaloUpdate4DI4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for sends to complete and deallocate arrays @@ -6041,19 +7405,28 @@ subroutine ice_HaloUpdate4DI4(array, halo, & call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif - deallocate(bufSend, bufRecv, bufTripole, stat=ierr) + deallocate(bufSend, bufRecv, stat=istat) - if (ierr > 0) then - call abort_ice(subname//'ERROR: deallocating 4d buffers') + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') return endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -6084,36 +7457,47 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & ! closed boundaries) real (dbl_kind), dimension(:,:,:), intent(inout) :: & - array1 ,& ! array containing field for which halo + array1, &! array containing field for which halo ! needs to be updated array2 ! array containing field for which halo ! in array1 needs to be updated ! local variables + integer (int_kind) :: & + n,nmsg, &! dummy loop indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids + + real (dbl_kind) :: & + fill ! value to use for unknown points + + real (dbl_kind), dimension(:,:), allocatable :: & + bufTripole ! tripole buffer + +#ifndef SERIAL_REMOVE_MPI integer (int_kind) :: & - n,nmsg, &! dummy loop indices - ierr, &! error or status flag for MPI,alloc - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + ierr, &! error or status flag for MPI,alloc + len ! length of messages + integer (int_kind), dimension(:), allocatable :: & - sndRequest, &! MPI request ids - rcvRequest ! MPI request ids + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids integer (int_kind), dimension(:,:), allocatable :: & - sndStatus, &! MPI status flags - rcvStatus ! MPI status flags - - real (dbl_kind) :: & - fill ! value to use for unknown points + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - integer (int_kind) :: len ! length of messages + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate_stress)' @@ -6147,11 +7531,17 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & endif nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - bufTripoleR8 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows), stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole arrays') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! allocate request and status arrays for messages @@ -6161,13 +7551,21 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & allocate(sndRequest(halo%numMsgSend), & rcvRequest(halo%numMsgRecv), & sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & - rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr) + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: allocating req,status arrays') return endif + allocate(bufSend(bufSizeSend, halo%numMsgSend), & + bufRecv(bufSizeRecv, halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufSend, bufRecv') + return + endif + !----------------------------------------------------------------------- ! ! post receives @@ -6177,7 +7575,7 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & do nmsg=1,halo%numMsgRecv len = halo%SizeRecv(nmsg) - call MPI_IRECV(bufRecvR8(1,nmsg), len, mpiR8, & + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & halo%recvTask(nmsg), & mpitagHalo + halo%recvTask(nmsg), & halo%communicator, rcvRequest(nmsg), ierr) @@ -6196,18 +7594,19 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & jSrc = halo%sendAddr(2,n,nmsg) srcBlock = halo%sendAddr(3,n,nmsg) - bufSendR8(n,nmsg) = array2(iSrc,jSrc,srcBlock) + bufSend(n,nmsg) = array2(iSrc,jSrc,srcBlock) end do do n=halo%sizeSend(nmsg)+1,bufSizeSend - bufSendR8(n,nmsg) = fill ! fill remainder of buffer + bufSend(n,nmsg) = fill ! fill remainder of buffer end do len = halo%SizeSend(nmsg) - call MPI_ISEND(bufSendR8(1,nmsg), len, mpiR8, & + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & halo%sendTask(nmsg), & mpitagHalo + my_task, & halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! @@ -6215,20 +7614,8 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & ! do NOT zero the halo out, this halo update just updates ! the tripole zipper as needed for stresses. if you zero ! it out, all halo values will be wiped out. +! !----------------------------------------------------------------------- -! do iblk = 1, halo%numLocalBlocks -! call get_block_parameter(halo%blockGlobalID(iblk), & -! ilo=ilo, ihi=ihi, & -! jlo=jlo, jhi=jhi) -! do j = 1,nghost -! array(1:nx_block, jlo-j,iblk) = fill -! array(1:nx_block, jhi+j,iblk) = fill -! enddo -! do i = 1,nghost -! array(ilo-i, 1:ny_block,iblk) = fill -! array(ihi+i, 1:ny_block,iblk) = fill -! enddo -! enddo !----------------------------------------------------------------------- ! @@ -6250,14 +7637,14 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & if (srcBlock > 0) then if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array2(iSrc,jSrc,srcBlock) + bufTripole(iDst,jDst) = array2(iSrc,jSrc,srcBlock) endif else if (srcBlock == 0) then array1(iDst,jDst,dstBlock) = fill endif end do +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! wait for receives to finish and then unpack the recv buffer into @@ -6274,10 +7661,17 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & dstBlock = halo%recvAddr(3,n,nmsg) if (dstBlock < 0) then !tripole - bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg) + bufTripole(iDst,jDst) = bufRecv(n,nmsg) endif end do end do +#endif + +!----------------------------------------------------------------------- +! +! No special code for zero_gradient or linear_extrap bcs, only a tripole update +! +!----------------------------------------------------------------------- !----------------------------------------------------------------------- ! @@ -6386,7 +7780,7 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array1(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc) + array1(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc) endif endif @@ -6400,15 +7794,32 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & ! !----------------------------------------------------------------------- +#ifndef SERIAL_REMOVE_MPI call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) - deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr) + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - if (ierr > 0) then + if (istat > 0) then call abort_ice(subname//'ERROR: deallocating req,status arrays') return endif + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufSend, bufRecv') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate_stress @@ -6433,6 +7844,7 @@ subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, & rcvCounter ! array for counting messages to be received character(len=*), parameter :: subname = '(ice_HaloIncrementMsgCount)' + !----------------------------------------------------------------------- ! ! error check @@ -6462,8 +7874,9 @@ subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, & ! !----------------------------------------------------------------------- - if (srcProc == my_task + 1) sndCounter(dstProc) = & - sndCounter(dstProc) + msgSize + if (srcProc == my_task + 1) then + sndCounter(dstProc) = sndCounter(dstProc) + msgSize + endif !----------------------------------------------------------------------- ! @@ -6494,25 +7907,24 @@ end subroutine ice_HaloIncrementMsgCount !*********************************************************************** - subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & - dstBlock, dstProc, dstLocalID, & - direction) + subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) ! This is a utility routine to determine the required address and ! message information for a particular pair of blocks. + type (distrb), intent(in) :: & + dist ! distribution of blocks across procs + integer (int_kind), intent(in) :: & - srcBlock, dstBlock, & ! source,destination block id - srcProc, dstProc, & ! source,destination processor location - srcLocalID, dstLocalID ! source,destination local index + srcBlock, dstBlock ! source,destination block id character (*), intent(in) :: & - direction ! direction of neighbor block - ! (north,south,east,west, - ! and NE, NW, SE, SW) + direction ! direction of neighbor block + ! (north,south,east,west, + ! and NE, NW, SE, SW) type (ice_halo), intent(inout) :: & - halo ! data structure containing halo info + halo ! data structure containing halo info !----------------------------------------------------------------------- ! @@ -6521,24 +7933,49 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & !----------------------------------------------------------------------- integer (int_kind) :: & + srcProc, srcLocalID, &! source block location in distribution + dstProc, dstLocalID, &! destination block location in distribution msgIndx, &! message counter and index into msg array - bufSize, &! size of message buffer ibSrc, ieSrc, jbSrc, jeSrc, &! phys domain info for source block ibDst, ieDst, jbDst, jeDst, &! phys domain info for dest block nxGlobal, &! size of global domain in e-w direction + bufSize, &! size of message buffer i,j,n ! dummy loop index integer (int_kind), dimension(:), pointer :: & iGlobal ! global i index for location in tripole character(len=*), parameter :: subname = '(ice_HaloMsgCreate)' + !----------------------------------------------------------------------- ! ! initialize ! !----------------------------------------------------------------------- - if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1) + nxGlobal = nxGlobal_size + +!----------------------------------------------------------------------- +! +! find source and destination block locations +! +!----------------------------------------------------------------------- + + if (srcBlock /= 0) then + call ice_DistributionGetBlockLoc(dist, abs(srcBlock), srcProc, & + srcLocalID) + else + srcProc = 0 + srcLocalID = 0 + endif + + if (dstBlock /= 0) then + call ice_DistributionGetBlockLoc(dist, abs(dstBlock), dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif !----------------------------------------------------------------------- ! @@ -6592,7 +8029,7 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & msgIndx > size(halo%dstLocalAddr,dim=2)) then - call abort_ice(subname//'ERROR: msg count > array size') + call abort_ice(subname//'ERROR: msg count 1 > array size') return endif @@ -6855,7 +8292,7 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & msgIndx > size(halo%dstLocalAddr,dim=2)) then - call abort_ice(subname//'ERROR: msg count > array size') + call abort_ice(subname//'ERROR: msg count 2 > array size') return endif @@ -6872,7 +8309,7 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & msgIndx > size(halo%dstLocalAddr,dim=2)) then - call abort_ice(subname//'ERROR: msg count > array size') + call abort_ice(subname//'ERROR: msg count 3 > array size') return endif @@ -7070,10 +8507,11 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & msgIndx > size(halo%dstLocalAddr,dim=2)) then - call abort_ice(subname//'ERROR: msg count > array size') + call abort_ice(subname//'ERROR: msg count 4 > array size') return endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! ! if source block local and dest block remote, send a message @@ -7598,6 +9036,7 @@ subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & !*** already checked in previous case construct end select +#endif !----------------------------------------------------------------------- ! @@ -7618,8 +9057,7 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) ! This subroutine extrapolates ARRAY values into the ghost cells, ! and is intended for grid variables whose ghost cells -! would otherwise be set using the default boundary conditions (Dirichlet -! or Neumann). +! would otherwise be set using the default boundary conditions. ! ! This is the specific interface for double precision arrays ! corresponding to the generic interface ice_HaloExtrapolate @@ -7679,18 +9117,18 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) if (trim(ew_bndy_type) /= 'cyclic') then do n = 1, nghost ii = ilo - n ! gridcell to extrapolate to - do j = 1, ny_block + do j = jlo-nghost, jhi+nghost ARRAY(ii,j,iblk) = c2*ARRAY(ii+1,j,iblk) - ARRAY(ii+2,j,iblk) enddo enddo endif endif - if (this_block%iblock == nblocks_x) then ! east edge + if (this_block%iblock == nblocks_x) then ! east edge if (trim(ew_bndy_type) /= 'cyclic') then do n = 1, nghost ii = ihi + n ! gridcell to extrapolate to - do j = 1, ny_block + do j = jlo-nghost, jhi+nghost ARRAY(ii,j,iblk) = c2*ARRAY(ii-1,j,iblk) - ARRAY(ii-2,j,iblk) enddo enddo @@ -7701,20 +9139,20 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) if (trim(ns_bndy_type) /= 'cyclic') then do n = 1, nghost jj = jlo - n ! gridcell to extrapolate to - do i = 1, nx_block + do i = ilo-nghost, ihi+nghost ARRAY(i,jj,iblk) = c2*ARRAY(i,jj+1,iblk) - ARRAY(i,jj+2,iblk) enddo enddo endif endif - if (this_block%jblock == nblocks_y) then ! north edge + if (this_block%jblock == nblocks_y) then ! north edge if (trim(ns_bndy_type) /= 'cyclic' .and. & trim(ns_bndy_type) /= 'tripole' .and. & trim(ns_bndy_type) /= 'tripoleT' ) then do n = 1, nghost jj = jhi + n ! gridcell to extrapolate to - do i = 1, nx_block + do i = ilo-nghost, ihi+nghost ARRAY(i,jj,iblk) = c2*ARRAY(i,jj-1,iblk) - ARRAY(i,jj-2,iblk) enddo enddo @@ -7738,28 +9176,36 @@ subroutine ice_HaloDestroy(halo) type (ice_halo) :: & halo ! a new halo type with info for halo updates - integer (int_kind) :: & - istat ! error or status flag for MPI,alloc + integer (int_kind) :: & + istat ! error or status flag for MPI,alloc character(len=*), parameter :: subname = '(ice_HaloDestroy)' !----------------------------------------------------------------------- + deallocate(halo%srcLocalAddr, & + halo%dstLocalAddr, & + halo%blockGlobalID, stat=istat) + + if (istat > 0) then + call abort_ice(subname,' ERROR: deallocating src,dst') + return + endif + +#ifndef SERIAL_REMOVE_MPI deallocate(halo%sendTask, & halo%recvTask, & halo%sizeSend, & halo%sizeRecv, & halo%tripSend, & halo%tripRecv, & - halo%srcLocalAddr, & - halo%dstLocalAddr, & halo%sendAddr, & - halo%recvAddr, & - halo%blockGlobalID, stat=istat) + halo%recvAddr, stat=istat) if (istat > 0) then - call abort_ice(subname,' ERROR: deallocating') + call abort_ice(subname,' ERROR: deallocating send,recv') return endif +#endif end subroutine ice_HaloDestroy diff --git a/cicecore/cicedyn/infrastructure/comm/serial/ice_boundary.F90 b/cicecore/cicedyn/infrastructure/comm/serial/ice_boundary.F90 index 205f2150b..b75d0c3c7 100644 --- a/cicecore/cicedyn/infrastructure/comm/serial/ice_boundary.F90 +++ b/cicecore/cicedyn/infrastructure/comm/serial/ice_boundary.F90 @@ -1,9 +1,10 @@ !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +#define SERIAL_REMOVE_MPI module ice_boundary ! This module contains data types and routines for updating halo -! regions (ghost cells) +! regions (ghost cells) using MPI calls ! ! 2007-07-19: Phil Jones, Yoshi Yoshida, John Dennis ! new naming conventions, optimizations during @@ -12,26 +13,67 @@ module ice_boundary ! fixes for non-existent blocks ! 2008-01-28: Elizabeth Hunke replaced old routines with new POP ! infrastructure -! 2023-03-09: Tony Craig updated the implementation to fix bug in -! tripoleT and reduce number of copies in tripole overall. -! Because all blocks are local, can fill the tripole -! buffer from "north" copies. This is not true for -! the MPI version. +! 2026-02-16: T Craig refactored and added zero_gradient and linear_extrap +! boundary conditions. ice_HaloUpdate routines +! generated by code generation script and made +! fully compatible with use in serial version. +! +!----------------------------------------------------------------------- +! +! Some notes on tripole, A-H below are gridpoints at i = 1:nx_global +! where nx_global=8. The schematics below show the general layout of the center +! points on the tripole fold. More complex pictures are needed to show +! relative orientation and offsets of east, north, and northeast points +! across the fold. See also appendix E of the NEMO_manual, +! https://zenodo.org/record/6334656#.YiYirhPMLXQ. Note the NFtype=T +! is the tripole u-fold grid with T-grid=center, U-grid=east, V-grid=north, +! and F-grid=northeast points in CICE. NFtype=F is similar to tripoleT +! except for the treatment of the poles. The CICE implementation also +! averages all degenerate points, NEMO's strategy seems to be to copy +! data from one side of the tripole to the other for degenerate points. +! +! tripole: u-fold, fold is on north edge of ny_global +! north and northeast points on the fold are degenerate and averaged +! A,H,D,and E are pole points +! +! ny_global+2 H G F E D C B A @ny_global-1 +! ny_global+1 H G F E D C B A @ny_global +! ny_global A B C D E F G H +! ny_global-1 A B C D E F G H +! +! tripoleT: t-fold, fold is thru center of ny_global +! center and east points at ny_global are degenerate and averaged +! north and northeast point at ny_global are not prognostic, they are halos +! A and E are pole points +! +! ny_global+2 H G F E D C B A @ny_global-2 +! ny_global+1 H G F E D C B A @ny_global-1 +! ny_global A BH CG DF E FD GC HB A +! ny_global-1 A B C D E F G H +! ny_global-2 A B C D E F G H +! +!----------------------------------------------------------------------- + +#ifndef SERIAL_REMOVE_MPI + use mpi ! MPI Fortran module + use ice_communicate, only: mpiR4, mpiR8, mpitagHalo +#endif use ice_kinds_mod use ice_communicate, only: my_task - use ice_constants, only: field_type_scalar, & - field_type_vector, field_type_angle, & - field_type_unknown, field_type_noupdate, & - field_loc_center, field_loc_NEcorner, & - field_loc_Nface, field_loc_Eface, & - field_loc_unknown, field_loc_noupdate + use ice_constants, only: c0, c1, field_type_scalar, & + field_type_vector, field_type_angle, & + field_type_unknown, field_type_noupdate, & + field_loc_center, field_loc_NEcorner, & + field_loc_Nface, field_loc_Eface, & + field_loc_unknown, field_loc_noupdate use ice_global_reductions, only: global_maxval use ice_exit, only: abort_ice + use ice_fileunits, only: nu_diag use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted use ice_blocks, only: nx_block, ny_block, nghost, & - nblocks_tot, ice_blocksNorth, nblocks_x, nblocks_y, & + nblocks_tot, nblocks_x, nblocks_y, ice_blocksNorth, & ice_blocksSouth, ice_blocksEast, ice_blocksWest, & ice_blocksEast2, ice_blocksWest2, & ice_blocksNorthEast, ice_blocksNorthWest, & @@ -39,7 +81,7 @@ module ice_boundary ice_blocksSouthEast, ice_blocksSouthWest, & ice_blocksGetNbrID, get_block_parameter use ice_distribution, only: distrb, & - ice_distributionGetBlockLoc, ice_distributionGet + ice_distributionGetBlockLoc, ice_distributionGet implicit none private @@ -65,11 +107,28 @@ module ice_boundary nsBoundaryType, &! type of boundary to use in logical ns dir ewBoundaryType ! type of boundary to use in logical ew dir +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + numMsgSend, &! number of messages to send halo update + numMsgRecv ! number of messages to recv halo update + + integer (int_kind), dimension(:), pointer :: & + recvTask, &! task from which to recv each msg + sendTask, &! task to which to send each msg + sizeSend, &! size of each sent message + sizeRecv, &! size of each recvd message + tripSend, &! send msg tripole flag, 0=non-zipper block + tripRecv ! recv msg tripole flag, for masked halos + + integer (int_kind), dimension(:,:,:), pointer :: & + sendAddr, &! src addresses for each sent message + recvAddr ! dst addresses for each recvd message +#endif end type - public :: ice_HaloCreate, & + public :: ice_HaloCreate, & ice_HaloMask, & - ice_HaloUpdate, & + ice_HaloUpdate, & ice_HaloUpdate_stress, & ice_HaloExtrapolate, & ice_HaloDestroy @@ -95,18 +154,14 @@ module ice_boundary !----------------------------------------------------------------------- ! -! global buffers for tripole boundary +! Buffer size place holders ! !----------------------------------------------------------------------- - integer (int_kind), dimension(:,:), allocatable :: & - bufTripoleI4 - - real (real_kind), dimension(:,:), allocatable :: & - bufTripoleR4 - - real (dbl_kind), dimension(:,:), allocatable :: & - bufTripoleR8 + integer (int_kind) :: & + bufSizeSend = -1, &! max buffer size for send messages + bufSizeRecv = -1, &! max buffer size for recv messages + nxGlobal_size = -1 ! global tripole boundary size !*********************************************************************** @@ -153,8 +208,13 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & srcLocalID, dstLocalID, &! local block index of src,dst blocks blockSizeX, &! size of default physical domain in X blockSizeY, &! size of default physical domain in Y + maxTmp, &! temp for global maxval + maxSizeSend, maxSizeRecv, &! max buffer sizes + numMsgSend, numMsgRecv, &! number of messages for this halo eastMsgSize, westMsgSize, &! nominal sizes for e-w msgs northMsgSize, southMsgSize, &! nominal sizes for n-s msgs + tripoleMsgSize, &! size for tripole messages + tripoleMsgSizeOut, &! size for tripole messages tripoleRows, &! number of rows in tripole buffer cornerMsgSize, msgSize ! nominal size for corner msg @@ -189,41 +249,33 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & eastMsgSize = nghost*blockSizeY westMsgSize = nghost*blockSizeY southMsgSize = nghost*blockSizeX + northMsgSize = nghost*blockSizeX cornerMsgSize = nghost*nghost tripoleRows = nghost+1 !*** store some block info to fill haloes properly call ice_distributionGet(dist, numLocalBlocks=halo%numLocalBlocks) if (halo%numLocalBlocks > 0) then - allocate(halo%blockGlobalID(halo%numLocalBlocks)) + allocate(halo%blockGlobalID(halo%numLocalBlocks),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating halo%blockGlobalID') + return + endif call ice_distributionGet(dist, blockGlobalID=halo%blockGlobalID) endif if (nsBoundaryType == 'tripole' .or. nsBoundaryType == 'tripoleT') then tripoleTFlag = (nsBoundaryType == 'tripoleT') if (tripoleTflag) tripoleRows = tripoleRows+1 - northMsgSize = tripoleRows*blockSizeX - - !*** allocate tripole message buffers if not already done - - if (.not. allocated(bufTripoleR8)) then - allocate (bufTripoleI4(nxGlobal, tripoleRows), & - bufTripoleR4(nxGlobal, tripoleRows), & - bufTripoleR8(nxGlobal, tripoleRows), & - stat=istat) - - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating tripole buffers') - return - endif - endif - + !*** set tripole message size if not already done + if (nxGlobal_size < 0) nxGlobal_size = nxGlobal else tripoleTFlag = .false. - northMsgSize = nghost*blockSizeX endif halo%tripoleTFlag = tripoleTFlag halo%tripoleRows = tripoleRows + tripoleMsgSize = tripoleRows*blockSizeX + tripoleMsgSizeOut = tripoleRows*nx_block !----------------------------------------------------------------------- ! @@ -255,34 +307,39 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & ewBoundaryType, nsBoundaryType) if (northBlock > 0) then tripoleBlock = .false. + msgSize = northMsgSize call ice_distributionGetBlockLoc(dist, northBlock, dstProc, & dstLocalID) else if (northBlock < 0) then ! tripole north row, count block tripoleBlock = .true. + msgSize = tripoleMsgSize call ice_distributionGetBlockLoc(dist, abs(northBlock), & dstProc, dstLocalID) else tripoleBlock = .false. + msgSize = northMsgSize dstProc = 0 dstLocalID = 0 endif call ice_HaloIncrementMsgCount(sendCount, recvCount, & - srcProc, dstProc, northMsgSize) + srcProc, dstProc, msgSize) !*** if a tripole boundary block, also create a local !*** message into and out of tripole buffer if (tripoleBlock) then - !*** copy in + !*** copy out of tripole buffer - includes halo call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, srcProc, & - northMsgSize) + tripoleMsgSizeOut) - !*** copy out of tripole buffer - includes halo - call ice_HaloIncrementMsgCount(sendCount, recvCount, & + !*** copy in only required if dstProc not same as srcProc + if (dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, srcProc, & - (nghost+1)*nx_block) + msgSize) + endif endif !*** find south neighbor block and add to message count @@ -320,13 +377,10 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** if a tripole boundary block, non-local east neighbor !*** needs a chunk of the north boundary, so add a message !*** for that - -!echmod if (tripoleBlock .and. dstProc /= srcProc) then -! tcx,tcraig, 3/2023, this is not needed -! if (tripoleBlock) then -! call ice_HaloIncrementMsgCount(sendCount, recvCount, & -! srcProc, dstProc, northMsgSize) -! endif + if (tripoleBlock .and. dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, tripoleMsgSize) + endif !*** find west neighbor block and add to message count @@ -347,13 +401,10 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & !*** if a tripole boundary block, non-local west neighbor !*** needs a chunk of the north boundary, so add a message !*** for that - -!echmod if (tripoleBlock .and. dstProc /= srcProc) then -! tcx,tcraig, 3/2023, this is not needed -! if (tripoleBlock) then -! call ice_HaloIncrementMsgCount(sendCount, recvCount, & -! srcProc, dstProc, northMsgSize) -! endif + if (tripoleBlock .and. dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, tripoleMsgSize) + endif !*** find northeast neighbor block and add to message count @@ -365,13 +416,11 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_distributionGetBlockLoc(dist, neBlock, dstProc, & dstLocalID) + else if (neBlock < 0) then ! tripole north row + msgSize = tripoleMsgSize ! tripole needs whole top row of block -! tcx,tcraig, 3/2023, this is not needed -! else if (neBlock < 0) then ! tripole north row -! msgSize = northMsgSize ! tripole needs whole top row of block -! -! call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, & -! dstLocalID) + call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, & + dstLocalID) else dstProc = 0 dstLocalID = 0 @@ -390,13 +439,11 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_distributionGetBlockLoc(dist, nwBlock, dstProc, & dstLocalID) + else if (nwBlock < 0) then ! tripole north row, count block + msgSize = tripoleMsgSize ! tripole NE corner update - entire row needed -! tcx,tcraig, 3/2023, this is not needed -! else if (nwBlock < 0) then ! tripole north row, count block -! msgSize = northMsgSize ! tripole NE corner update - entire row needed -! -! call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, & -! dstLocalID) + call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, & + dstLocalID) else dstProc = 0 @@ -438,6 +485,94 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_HaloIncrementMsgCount(sendCount, recvCount, & srcProc, dstProc, cornerMsgSize) +#ifndef SERIAL_REMOVE_MPI + !*** for tripole grids with padded domain, padding will + !*** prevent tripole buffer from getting all the info + !*** it needs - must extend footprint at top boundary + !*** Only needed for multi-proc configurations + + if (tripoleBlock .and. & !tripole + mod(nxGlobal,blockSizeX) /= 0) then !padding + + !*** find east2 neighbor block and add to message count + + eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, & + ewBoundaryType, nsBoundaryType) + + if (eastBlock > 0) then + call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, tripoleMsgSize) + endif + + !*** find EastNorthEast neighbor block and add to message count + + neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, & + ewBoundaryType, nsBoundaryType) + + if (neBlock < 0) then ! tripole north row + msgSize = tripoleMsgSize ! tripole needs whole top row of block + + call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, msgSize) + endif + + !*** find west2 neighbor block and add to message count + + westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, & + ewBoundaryType, nsBoundaryType) + + if (westBlock > 0) then + call ice_distributionGetBlockLoc(dist, westBlock, dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, tripoleMsgSize) + endif + + !*** find WestNorthWest neighbor block and add to message count + + nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, & + ewBoundaryType, nsBoundaryType) + + if (nwBlock < 0) then ! tripole north row + msgSize = tripoleMsgSize ! tripole needs whole top row of block + + call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloIncrementMsgCount(sendCount, recvCount, & + srcProc, dstProc, msgSize) + endif + + endif +#endif + end do msgCountLoop !----------------------------------------------------------------------- @@ -452,24 +587,74 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & sendCount(my_task+1) = 0 recvCount(my_task+1) = 0 -!----------------------------------------------------------------------- -! -! allocate arrays for message information and initialize -! -!----------------------------------------------------------------------- - allocate(halo%srcLocalAddr(3,halo%numLocalCopies), & halo%dstLocalAddr(3,halo%numLocalCopies), & - stat = istat) + stat=istat) if (istat > 0) then - call abort_ice(subname//'ERROR: allocating halo message info arrays') + call abort_ice(subname//'ERROR: allocating LocalAddr arrays') return endif halo%srcLocalAddr = 0 halo%dstLocalAddr = 0 +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! now count the number of actual messages to be sent and received +! +!----------------------------------------------------------------------- + + numMsgSend = count(sendCount /= 0) + numMsgRecv = count(recvCount /= 0) + halo%numMsgSend = numMsgSend + halo%numMsgRecv = numMsgRecv + +!----------------------------------------------------------------------- +! +! allocate buffers for 2-d halo updates to save time later +! if the buffers are already allocated by previous create call, +! check to see if they need to be re-sized +! +!----------------------------------------------------------------------- + + maxTmp = maxval(sendCount) + maxSizeSend = global_maxval(maxTmp, dist) + maxTmp = maxval(recvCount) + maxSizeRecv = global_maxval(maxTmp, dist) + + bufSizeSend = max(bufSizeSend,maxSizeSend) + bufSizeRecv = max(bufSizeRecv,maxSizeRecv) + +!----------------------------------------------------------------------- +! +! allocate arrays for message information and initialize +! +!----------------------------------------------------------------------- + + allocate(halo%sendTask(numMsgSend), & + halo%recvTask(numMsgRecv), & + halo%sizeSend(numMsgSend), & + halo%sizeRecv(numMsgRecv), & + halo%tripSend(numMsgSend), & + halo%tripRecv(numMsgRecv), & + halo%sendAddr(3,bufSizeSend,numMsgSend), & + halo%recvAddr(3,bufSizeRecv,numMsgRecv), & + stat = istat) + + halo%sendTask = 0 + halo%recvTask = 0 + halo%sizeSend = 0 + halo%sizeRecv = 0 + halo%tripSend = 0 + halo%tripRecv = 0 + halo%sendAddr = 0 + halo%recvAddr = 0 + halo%numMsgSend = 0 + halo%numMsgRecv = 0 +#endif + deallocate(sendCount, recvCount, stat=istat) if (istat > 0) then @@ -493,90 +678,207 @@ function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, & call ice_distributionGetBlockLoc(dist, iblock, srcProc, & srcLocalID) - !*** find north neighbor block + !*** find north neighbor block and set msg info + !*** also set tripole block flag for later special cases northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, & ewBoundaryType, nsBoundaryType) - !*** set tripole flag and add two copies for inserting - !*** and extracting info from the tripole buffer - - if (northBlock < 0) then + if (northBlock > 0) then + tripoleBlock = .false. + call ice_distributionGetBlockLoc(dist, northBlock, dstProc, & + dstLocalID) + else if (northBlock < 0) then ! tripole north row, count block tripoleBlock = .true. - call ice_HaloMsgCreate(halo, dist, iblock, -iblock, 'north') - call ice_HaloMsgCreate(halo, dist, -iblock, iblock, 'north') + call ice_distributionGetBlockLoc(dist, abs(northBlock), & + dstProc, dstLocalID) else tripoleBlock = .false. - call ice_HaloMsgCreate(halo, dist, iblock, northBlock, 'north') + dstProc = 0 + dstLocalID = 0 + endif + + call ice_HaloMsgCreate(halo, dist, iblock, northBlock, 'north') + + !*** if a tripole boundary block, also create a local + !*** message into and out of tripole buffer + + if (tripoleBlock) then + !*** copy out of tripole buffer - includes halo + call ice_HaloMsgCreate(halo, dist,-iblock, iblock, 'north') + + !*** copy in only required if dstProc not same as srcProc + if (dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, -iblock, 'north') + + endif endif - !*** find south neighbor block + !*** find south neighbor block and add to message count southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, & ewBoundaryType, nsBoundaryType) - call ice_HaloMsgCreate(halo, dist, iblock, southBlock, 'south') - !*** find east neighbor block + !*** find east neighbor block and add to message count eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, & ewBoundaryType, nsBoundaryType) + if (eastBlock > 0) then + call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + call ice_HaloMsgCreate(halo, dist, iblock, eastBlock, 'east') - !*** for tripole grids, send a north tripole message to - !*** the east block to make sure enough information is - !*** available for tripole manipulations + !*** if a tripole boundary block, non-local east neighbor + !*** needs a chunk of the north boundary, so add a message + !*** for that -! tcx,tcraig, 3/2023, this is not needed -! if (tripoleBlock) then -! call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north') -! endif + if (tripoleBlock .and. dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north') + endif - !*** find west neighbor block + !*** find west neighbor block and add to message count westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, & ewBoundaryType, nsBoundaryType) + if (westBlock > 0) then + call ice_distributionGetBlockLoc(dist, westBlock, dstProc, & + dstLocalID) + else + dstProc = 0 + dstLocalID = 0 + endif + call ice_HaloMsgCreate(halo, dist, iblock, westBlock, 'west') - !*** for tripole grids, send a north tripole message to - !*** the west block to make sure enough information is - !*** available for tripole manipulations + !*** if a tripole boundary block, non-local west neighbor + !*** needs a chunk of the north boundary, so add a message + !*** for that -! tcx,tcraig, 3/2023, this is not needed -! if (tripoleBlock) then -! call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north') -! endif + if (tripoleBlock .and. dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north') + endif - !*** find northeast neighbor block + !*** find northeast neighbor block and add to message count neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, & ewBoundaryType, nsBoundaryType) - call ice_HaloMsgCreate(halo, dist, iblock, neBlock, 'northeast') - !*** find northwest neighbor block + !*** find northwest neighbor block and add to message count nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, & ewBoundaryType, nsBoundaryType) - call ice_HaloMsgCreate(halo, dist, iblock, nwBlock, 'northwest') - !*** find southeast neighbor block + !*** find southeast neighbor block and add to message count seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, & ewBoundaryType, nsBoundaryType) - call ice_HaloMsgCreate(halo, dist, iblock, seBlock, 'southeast') - !*** find southwest neighbor block + !*** find southwest neighbor block and add to message count swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, & ewBoundaryType, nsBoundaryType) - call ice_HaloMsgCreate(halo, dist, iblock, swBlock, 'southwest') +#ifndef SERIAL_REMOVE_MPI + !*** for tripole grids with padded domain, padding will + !*** prevent tripole buffer from getting all the info + !*** it needs - must extend footprint at top boundary + !*** Only needed for multi-proc configurations + + if (tripoleBlock .and. & !tripole + mod(nxGlobal,blockSizeX) /= 0) then !padding + + !*** find east2 neighbor block and add to message count + + eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, & + ewBoundaryType, nsBoundaryType) + + if (eastBlock > 0) then + call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, & + dstLocalID) + + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north') + endif + + !*** find EastNorthEast neighbor block and add to message count + + neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, & + ewBoundaryType, nsBoundaryType) + + if (neBlock < 0) then ! tripole north row + msgSize = tripoleMsgSize ! tripole needs whole top row of block + + call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, & + dstLocalID) + + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, neBlock, 'north') + endif + + !*** find west2 neighbor block and add to message count + + westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, & + ewBoundaryType, nsBoundaryType) + + if (westBlock > 0) then + call ice_distributionGetBlockLoc(dist, westBlock, dstProc, & + dstLocalID) + + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north') + endif + + !*** find WestNorthWest neighbor block and add to message count + + nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, & + ewBoundaryType, nsBoundaryType) + + if (nwBlock < 0) then ! tripole north row + msgSize = tripoleMsgSize ! tripole needs whole top row of block + + call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, & + dstLocalID) + + else + dstProc = 0 + dstLocalID = 0 + endif + + if (dstProc /= srcProc) then + call ice_HaloMsgCreate(halo, dist, iblock, nwBlock, 'north') + + endif + + endif +#endif + end do msgConfigLoop !----------------------------------------------------------------------- @@ -594,7 +896,7 @@ subroutine ice_HaloMask(halo, basehalo, mask) use ice_domain_size, only: max_blocks type (ice_halo) :: & - basehalo ! basehalo to mask + basehalo ! basehalo to mask integer (int_kind), intent(in) :: & mask(nx_block,ny_block,max_blocks) ! mask of live points @@ -607,15 +909,25 @@ subroutine ice_HaloMask(halo, basehalo, mask) ! !----------------------------------------------------------------------- - integer (int_kind) :: & - istat, &! allocate status flag - communicator, &! communicator for message passing - numLocalCopies, &! num local copies for halo update - numLocalBlocks, &! num local blocks for halo fill - tripoleRows ! number of rows in tripole buffer + integer (int_kind) :: & + istat, &! allocate status flag + communicator, &! communicator for message passing + numLocalCopies, &! num local copies for halo update + numLocalBlocks, &! num local blocks for halo fill + tripoleRows ! number of rows in tripole buffer logical (log_kind) :: & - tripoleTFlag ! flag for processing tripole buffer as T-fold + tripoleTFlag, &! flag for processing tripole buffer as T-fold + tmpflag ! temporary flag for setting halomask along T-fold + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + n,nmsg,scnt, &! counters + icel,jcel,nblock, &! gridcell index + numMsgSend, numMsgRecv, &! number of messages for this halo + lbufSizeSend, &! buffer size for send messages + lbufSizeRecv ! buffer size for recv messages +#endif character(len=*), parameter :: subname = '(ice_HaloMask)' @@ -626,32 +938,125 @@ subroutine ice_HaloMask(halo, basehalo, mask) ! !----------------------------------------------------------------------- - communicator = basehalo%communicator - tripoleRows = basehalo%tripoleRows - tripoleTFlag = basehalo%tripoleTFlag - numLocalCopies = basehalo%numLocalCopies - numLocalBlocks = basehalo%numLocalBlocks + communicator = basehalo%communicator + tripoleRows = basehalo%tripoleRows + tripoleTFlag = basehalo%tripoleTFlag + numLocalCopies = basehalo%numLocalCopies + numLocalBlocks = basehalo%numLocalBlocks - allocate(halo%srcLocalAddr(3,numLocalCopies), & - halo%dstLocalAddr(3,numLocalCopies), & - halo%blockGlobalID(numLocalBlocks), & - stat = istat) + allocate(halo%srcLocalAddr(3,numLocalCopies), & + halo%dstLocalAddr(3,numLocalCopies), & + halo%blockGlobalID(numLocalBlocks), & + stat = istat) - if (istat > 0) then - call abort_ice(subname//'ERROR: allocating halo message info arrays') - return - endif + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating src,dst LocalAddr arrays') + return + endif + + halo%communicator = communicator + halo%tripoleRows = tripoleRows + halo%tripoleTFlag = tripoleTFlag + halo%numLocalCopies = numLocalCopies + halo%numLocalBlocks = numLocalBlocks + + halo%srcLocalAddr = basehalo%srcLocalAddr(:,1:numLocalCopies) + halo%dstLocalAddr = basehalo%dstLocalAddr(:,1:numLocalCopies) + + halo%blockGlobalID = basehalo%blockGlobalID + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! mask communication part of halo +! always keep tripole zipper msgs! +! +!----------------------------------------------------------------------- + + numMsgSend = basehalo%numMsgSend + numMsgRecv = basehalo%numMsgRecv + lbufSizeSend = size(basehalo%sendAddr,dim=2) + lbufSizeRecv = size(basehalo%recvAddr,dim=2) - halo%communicator = communicator - halo%tripoleRows = tripoleRows - halo%tripoleTFlag = tripoleTFlag - halo%numLocalCopies = numLocalCopies - halo%numLocalBlocks = numLocalBlocks + allocate(halo%sendTask(numMsgSend), & + halo%recvTask(numMsgRecv), & + halo%sizeSend(numMsgSend), & + halo%sizeRecv(numMsgRecv), & + halo%tripSend(numMsgSend), & + halo%tripRecv(numMsgRecv), & + halo%sendAddr(3,lbufSizeSend,numMsgSend), & + halo%recvAddr(3,lbufSizeRecv,numMsgRecv), & + stat = istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating halo send,recv arrays') + return + endif + + numMsgSend = 0 + do nmsg=1,basehalo%numMsgSend + scnt = 0 + do n=1,basehalo%sizeSend(nmsg) + icel = basehalo%sendAddr(1,n,nmsg) + jcel = basehalo%sendAddr(2,n,nmsg) + nblock = basehalo%sendAddr(3,n,nmsg) +! the following line fails bounds check for mask when tripSend /= 0 +! if (mask(icel,jcel,abs(nblock)) /= 0 .or. basehalo%tripSend(nmsg) /= 0) then + tmpflag = .false. + if (basehalo%tripSend(nmsg) /= 0) then + tmpflag = .true. + elseif (mask(icel,jcel,abs(nblock)) /= 0) then + tmpflag = .true. + endif - halo%srcLocalAddr = basehalo%srcLocalAddr - halo%dstLocalAddr = basehalo%dstLocalAddr + if (tmpflag) then + scnt = scnt + 1 + if (scnt == 1) then + numMsgSend = numMsgSend + 1 + halo%sendTask(numMsgSend) = basehalo%sendTask(nmsg) + halo%tripSend(numMsgSend) = basehalo%tripSend(nmsg) + endif + halo%sendAddr(1,scnt,numMsgSend) = icel + halo%sendAddr(2,scnt,numMsgSend) = jcel + halo%sendAddr(3,scnt,numMsgSend) = nblock + halo%sizeSend(numMsgSend) = scnt + endif + enddo + enddo + halo%numMsgSend = numMsgSend + + numMsgRecv = 0 + do nmsg=1,basehalo%numMsgRecv + scnt = 0 + do n=1,basehalo%sizeRecv(nmsg) + icel = basehalo%recvAddr(1,n,nmsg) + jcel = basehalo%recvAddr(2,n,nmsg) + nblock = basehalo%recvAddr(3,n,nmsg) +! the following line fails bounds check for mask when tripRecv /= 0 +! if (mask(icel,jcel,abs(nblock)) /= 0 .or. basehalo%tripRecv(nmsg) /= 0) then + tmpflag = .false. + if (basehalo%tripRecv(nmsg) /= 0) then + tmpflag = .true. + elseif (mask(icel,jcel,abs(nblock)) /= 0) then + tmpflag = .true. + endif - halo%blockGlobalID = basehalo%blockGlobalID + if (tmpflag) then + scnt = scnt + 1 + if (scnt == 1) then + numMsgRecv = numMsgRecv + 1 + halo%recvTask(numMsgRecv) = basehalo%recvTask(nmsg) + halo%tripRecv(numMsgRecv) = basehalo%tripRecv(nmsg) + endif + halo%recvAddr(1,scnt,numMsgRecv) = icel + halo%recvAddr(2,scnt,numMsgRecv) = jcel + halo%recvAddr(3,scnt,numMsgRecv) = nblock + halo%sizeRecv(numMsgRecv) = scnt + endif + enddo + enddo + halo%numMsgRecv = numMsgRecv +#endif !----------------------------------------------------------------------- @@ -659,14 +1064,18 @@ end subroutine ice_HaloMask !*********************************************************************** - subroutine ice_HaloUpdate2DR8(array, halo, & + subroutine ice_HaloUpdate2DR8(array, halo, & fieldLoc, fieldKind, & fillValue, tripoleOnly) +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. + ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -696,26 +1105,48 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter, &! fill outer boundary ns - ltripoleOnly ! local tripoleOnly value + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (dbl_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DR8)' @@ -742,14 +1173,14 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic or tripole - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -757,7 +1188,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind endif if (present(tripoleOnly)) then @@ -766,23 +1197,104 @@ subroutine ice_HaloUpdate2DR8(array, halo, & ltripoleOnly = .false. endif + nz = 1 + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - bufTripoleR8 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - if (.not. ltripoleOnly) then + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then ! tripoleOnly skip fill, do not overwrite any values in interior as they may ! already be set and filling tripole is not necessary @@ -795,29 +1307,29 @@ subroutine ice_HaloUpdate2DR8(array, halo, & iblock=iblock, jblock=jblock) if (ewfillouter .or. iblock > 1) then ! west edge do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill + array(ilo-i,jlo:jhi,iblk) = fill enddo endif if (ewfillouter .or. iblock < nblocks_x) then ! east edge do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill + array(ihi+i,jlo:jhi,iblk) = fill enddo endif if (nsfillouter .or. jblock > 1) then ! south edge do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill + array(ilo:ihi,jlo-j,iblk) = fill enddo endif if (nsfillouter .or. jblock < nblocks_y) then ! north edge do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill + array(ilo:ihi,jhi+j,iblk) = fill enddo endif if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner (nsfillouter .or. jblock > 1)) then do j = 1,nghost do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill + array(ilo-i,jlo-j,iblk) = fill enddo enddo endif @@ -825,7 +1337,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock < nblocks_y)) then do j = 1,nghost do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill + array(ilo-i,jhi+j,iblk) = fill enddo enddo endif @@ -833,7 +1345,7 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock > 1)) then do j = 1,nghost do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill + array(ihi+i,jlo-j,iblk) = fill enddo enddo endif @@ -841,12 +1353,12 @@ subroutine ice_HaloUpdate2DR8(array, halo, & (nsfillouter .or. jblock < nblocks_y)) then do j = 1,nghost do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill + array(ihi+i,jhi+j,iblk) = fill enddo enddo endif enddo ! iblk - endif + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -866,28 +1378,168 @@ subroutine ice_HaloUpdate2DR8(array, halo, & jDst = halo%dstLocalAddr(2,nmsg) dstBlock = halo%dstLocalAddr(3,nmsg) - if (ltripoleOnly) then - if (srcBlock > 0) then - if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do endif - else - if (srcBlock > 0) then - if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) - else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) - endif - else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do endif endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -920,13 +1572,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -942,13 +1598,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -976,13 +1636,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -998,13 +1662,17 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR8(i ,halo%tripoleRows) - x2 = bufTripoleR8(iDst,halo%tripoleRows) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripoleR8(i ,halo%tripoleRows) = xavg - bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -1044,7 +1712,11 @@ subroutine ice_HaloUpdate2DR8(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -1052,20 +1724,56 @@ subroutine ice_HaloUpdate2DR8(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DR8 !*********************************************************************** - subroutine ice_HaloUpdate2DR4(array, halo, & + subroutine ice_HaloUpdate2DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -1082,6 +1790,9 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -1092,25 +1803,48 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (real_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DR4)' @@ -1137,14 +1871,14 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -1152,156 +1886,401 @@ subroutine ice_HaloUpdate2DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif + nz = 1 + nt = 1 + nxGlobal = 0 - if (allocated(bufTripoleR4)) then - nxGlobal = size(bufTripoleR4,dim=1) - bufTripoleR4 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif + bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif !----------------------------------------------------------------------- ! -! do local copies while waiting for messages to complete -! if srcBlock is zero, that denotes an eliminated land block or a -! closed boundary where ghost cell values are undefined -! if srcBlock is less than zero, the message is a copy out of the -! tripole buffer and will be treated later +! post receives ! !----------------------------------------------------------------------- - do nmsg=1,halo%numLocalCopies - iSrc = halo%srcLocalAddr(1,nmsg) - jSrc = halo%srcLocalAddr(2,nmsg) - srcBlock = halo%srcLocalAddr(3,nmsg) - iDst = halo%dstLocalAddr(1,nmsg) - jDst = halo%dstLocalAddr(2,nmsg) - dstBlock = halo%dstLocalAddr(3,nmsg) - - if (srcBlock > 0) then - if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) - else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR4(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) - endif - else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill - endif + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) end do !----------------------------------------------------------------------- ! -! take care of northern boundary in tripole case -! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows -! (T-fold) of physical domain for entire (global) top row +! fill send buffer and post sends ! !----------------------------------------------------------------------- - if (nxGlobal > 0) then + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) - select case (fieldKind) - case (field_type_scalar) - isign = 1 - case (field_type_vector) - isign = -1 - case (field_type_angle) - isign = -1 - case default - call abort_ice(subname//'ERROR: Unknown field kind') - end select + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do + end do - if (halo%tripoleTFlag) then + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do - select case (fieldLoc) - case (field_loc_center) ! cell center location + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif - ioffset = -1 - joffset = 0 +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly + +!----------------------------------------------------------------------- +! +! do local copies while waiting for messages to complete +! if srcBlock is zero, that denotes an eliminated land block or a +! closed boundary where ghost cell values are undefined +! if srcBlock is less than zero, the message is a copy out of the +! tripole buffer and will be treated later +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numLocalCopies + iSrc = halo%srcLocalAddr(1,nmsg) + jSrc = halo%srcLocalAddr(2,nmsg) + srcBlock = halo%srcLocalAddr(3,nmsg) + iDst = halo%dstLocalAddr(1,nmsg) + jDst = halo%dstLocalAddr(2,nmsg) + dstBlock = halo%dstLocalAddr(3,nmsg) + + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do + endif + endif + end do + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + +!----------------------------------------------------------------------- +! +! take care of northern boundary in tripole case +! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows +! (T-fold) of physical domain for entire (global) top row +! +!----------------------------------------------------------------------- + + if (nxGlobal > 0) then + + select case (fieldKind) + case (field_type_scalar) + isign = 1 + case (field_type_vector) + isign = -1 + case (field_type_angle) + isign = -1 + case default + call abort_ice(subname//'ERROR: Unknown field kind') + end select + + if (halo%tripoleTFlag) then + + select case (fieldLoc) + case (field_loc_center) ! cell center location + + ioffset = -1 + joffset = 0 !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -1317,13 +2296,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -1351,13 +2334,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -1373,13 +2360,17 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleR4(i ,halo%tripoleRows) - x2 = bufTripoleR4(iDst,halo%tripoleRows) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripoleR4(i ,halo%tripoleRows) = xavg - bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -1419,7 +2410,11 @@ subroutine ice_HaloUpdate2DR4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -1427,20 +2422,56 @@ subroutine ice_HaloUpdate2DR4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DR4 !*********************************************************************** - subroutine ice_HaloUpdate2DI4(array, halo, & + subroutine ice_HaloUpdate2DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 2d horizontal integer arrays. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -1457,6 +2488,9 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -1467,25 +2501,48 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + integer (int_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate2DI4)' @@ -1512,14 +2569,14 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -1527,85 +2584,177 @@ subroutine ice_HaloUpdate2DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 endif - nxGlobal = 0 - if (allocated(bufTripoleI4)) then - nxGlobal = size(bufTripoleI4,dim=1) - bufTripoleI4 = fill + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif -!----------------------------------------------------------------------- -! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data -! -!----------------------------------------------------------------------- + nz = 1 + nt = 1 - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, iblk) = fill - enddo - enddo + nxGlobal = 0 + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return endif - enddo ! iblk + bufTripole = fill + endif + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! allocate request and status arrays for messages +! allocate send/recv buffers +! +!----------------------------------------------------------------------- + + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! @@ -1627,17 +2776,166 @@ subroutine ice_HaloUpdate2DI4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - array(iDst,jDst,dstBlock) = & - array(iSrc,jSrc,srcBlock) + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = array(iSrc,jSrc,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleI4(iDst,jDst) = & - array(iSrc,jSrc,srcBlock) + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,srcBlock) + end do + end do endif else if (srcBlock == 0) then - array(iDst,jDst,dstBlock) = fill + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,iblk) = array(ilo,j,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,iblk)-array(ilo,j,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,iblk) = array(ihi,j,iblk) + & + real((i),dbl_kind)*(array(ihi,j,iblk)-array(ihi-1,j,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,iblk) = array(i,jlo,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,iblk)-array(i,jlo,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,iblk) = array(i,jhi,iblk) + & + real((j),dbl_kind)*(array(i,jhi,iblk)-array(i,jhi-1,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -1670,13 +2968,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_NEcorner) ! cell corner location @@ -1692,13 +2994,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Nface) ! cell corner (velocity) location @@ -1726,13 +3032,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case (field_loc_Eface) ! cell center location @@ -1748,13 +3058,17 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt + do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripoleI4(i ,halo%tripoleRows) - x2 = bufTripoleI4(iDst,halo%tripoleRows) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripoleI4(i ,halo%tripoleRows) = xavg - bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do + end do end do case default @@ -1794,7 +3108,11 @@ subroutine ice_HaloUpdate2DI4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc) + do l=1,nt + do k=1,nz + array(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do + end do endif endif @@ -1802,15 +3120,47 @@ subroutine ice_HaloUpdate2DI4(array, halo, & endif +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif + !----------------------------------------------------------------------- end subroutine ice_HaloUpdate2DI4 !*********************************************************************** - subroutine ice_HaloUpdate2DL1(array, halo, & + subroutine ice_HaloUpdate2DL1(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface @@ -1826,12 +3176,15 @@ subroutine ice_HaloUpdate2DL1(array, halo, & fieldLoc ! id for location on horizontal grid ! (center, NEcorner, Nface, Eface) - integer (int_kind), intent(in), optional :: & + logical (log_kind), intent(in), optional :: & fillValue ! optional value to put in ghost cells ! where neighbor points are unknown ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + logical (log_kind), dimension(:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -1842,45 +3195,51 @@ subroutine ice_HaloUpdate2DL1(array, halo, & ! !----------------------------------------------------------------------- + integer (int_kind) :: & + istat ! allocate return status + integer (int_kind), dimension(:,:,:), allocatable :: & - iarray ! integer array for logical + iarray ! array containing field for which halo + + integer (int_kind) :: & + ifillValue ! fill value character(len=*), parameter :: subname = '(ice_HaloUpdate2DL1)' -!----------------------------------------------------------------------- -! -! abort or return on unknown or noupdate field_loc or field_type -! !----------------------------------------------------------------------- - if (fieldLoc == field_loc_unknown .or. & - fieldKind == field_type_unknown) then - call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed') + allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3)),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating iarray') return endif - if (fieldLoc == field_loc_noupdate .or. & - fieldKind == field_type_noupdate) then - return + iarray = 0 + where (array) iarray = 1 + if (present(fillValue)) then + ifillValue = 0 + if (fillValue) ifillValue = 1 + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + ifillValue, tripoleOnly) + else + call ice_HaloUpdate(iarray, halo, & + fieldLoc, fieldKind, & + tripoleOnly=tripoleOnly) endif -!----------------------------------------------------------------------- -! -! copy logical into integer array and call haloupdate on integer array -! -!----------------------------------------------------------------------- - - allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3))) - iarray(:,:,:) = 0 - where (array) iarray = 1 - - call ice_HaloUpdate(iarray, halo, & - fieldLoc, fieldKind, & - fillValue) - + ! tcraig, for most BCs, the mod is not needed, iarray will always be 0 or 1. + ! for linear_extrap, the bc is not a simple copy, it's a computation from neighbor + ! points. Use the mod to provide a more consistent result for linear_extrap bcs for + ! logicals. array = .false. - where (iarray /= 0) array = .true. - deallocate(iarray) + where (mod(abs(iarray),2) /= 0) array = .true. + + deallocate(iarray, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating iarray') + return + endif !----------------------------------------------------------------------- @@ -1888,14 +3247,18 @@ end subroutine ice_HaloUpdate2DL1 !*********************************************************************** - subroutine ice_HaloUpdate3DR8(array, halo, & + subroutine ice_HaloUpdate3DR8(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -1912,6 +3275,9 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (dbl_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -1922,29 +3288,48 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam + + real (dbl_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags - real (dbl_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DR8)' @@ -1971,14 +3356,14 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -1986,92 +3371,181 @@ subroutine ice_HaloUpdate3DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) + nt = 1 nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! -! do local copies +! do local copies while waiting for messages to complete ! if srcBlock is zero, that denotes an eliminated land block or a ! closed boundary where ghost cell values are undefined ! if srcBlock is less than zero, the message is a copy out of the @@ -2089,23 +3563,166 @@ subroutine ice_HaloUpdate3DR8(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -2138,14 +3755,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2162,14 +3781,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2198,14 +3819,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2222,14 +3845,16 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_dbl_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2270,9 +3895,10 @@ subroutine ice_HaloUpdate3DR8(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -2281,7 +3907,37 @@ subroutine ice_HaloUpdate3DR8(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -2289,14 +3945,18 @@ end subroutine ice_HaloUpdate3DR8 !*********************************************************************** - subroutine ice_HaloUpdate3DR4(array, halo, & + subroutine ice_HaloUpdate3DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -2313,6 +3973,9 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -2323,29 +3986,48 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam - real (real_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + real (real_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DR4)' @@ -2372,14 +4054,14 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -2387,92 +4069,181 @@ subroutine ice_HaloUpdate3DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) + nt = 1 nxGlobal = 0 - if (allocated(bufTripoleR4)) then - nxGlobal = size(bufTripoleR4,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! -! do local copies +! do local copies while waiting for messages to complete ! if srcBlock is zero, that denotes an eliminated land block or a ! closed boundary where ghost cell values are undefined ! if srcBlock is less than zero, the message is a copy out of the @@ -2490,23 +4261,166 @@ subroutine ice_HaloUpdate3DR4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -2539,14 +4453,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2563,14 +4479,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2599,14 +4517,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2623,14 +4543,16 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) - xavg = 0.5_real_kind*(x1 + isign*x2) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) + xavg = (0.5_real_kind*(x1 + isign*x2)) + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2671,9 +4593,10 @@ subroutine ice_HaloUpdate3DR4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -2682,7 +4605,37 @@ subroutine ice_HaloUpdate3DR4(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -2690,14 +4643,18 @@ end subroutine ice_HaloUpdate3DR4 !*********************************************************************** - subroutine ice_HaloUpdate3DI4(array, halo, & + subroutine ice_HaloUpdate3DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 3d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -2714,6 +4671,9 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -2724,29 +4684,48 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, &! size of array in 3rd dimension - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam - integer (int_kind), dimension(:,:,:), allocatable :: & - bufTripole ! 3d tripole buffer + integer (int_kind), dimension(:,:,:,:), allocatable :: & + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate3DI4)' @@ -2773,14 +4752,14 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -2788,92 +4767,181 @@ subroutine ice_HaloUpdate3DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) + nt = 1 nxGlobal = 0 - if (allocated(bufTripoleI4)) then - nxGlobal = size(bufTripoleI4,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif + +!----------------------------------------------------------------------- +! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly !----------------------------------------------------------------------- ! -! do local copies +! do local copies while waiting for messages to complete ! if srcBlock is zero, that denotes an eliminated land block or a ! closed boundary where ghost cell values are undefined ! if srcBlock is less than zero, the message is a copy out of the @@ -2891,23 +4959,166 @@ subroutine ice_HaloUpdate3DI4(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = & - array(iSrc,jSrc,k,srcBlock) - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = array(iSrc,jSrc,k,srcBlock) + end do + end do + endif else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k) = & - array(iSrc,jSrc,k,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,srcBlock) + end do end do endif else if (srcBlock == 0) then - do k=1,nz - array(iDst,jDst,k,dstBlock) = fill - end do + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,dstBlock) = fill + end do + end do + endif endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,iblk) = array(ilo,j,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,iblk)-array(ilo,j,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,iblk) = array(ihi,j,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,iblk)-array(ihi-1,j,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,iblk) = array(i,jlo,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,iblk)-array(i,jlo,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,iblk) = array(i,jhi,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,iblk)-array(i,jhi-1,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -2940,14 +5151,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 2,nxGlobal/2 iDst = nxGlobal - i + 2 - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -2964,14 +5177,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3000,14 +5215,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 - 1 iDst = nxGlobal - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3024,14 +5241,16 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** top row is degenerate, so must enforce symmetry !*** use average of two degenerate points for value + do l=1,nt do k=1,nz do i = 1,nxGlobal/2 iDst = nxGlobal + 1 - i - x1 = bufTripole(i ,halo%tripoleRows,k) - x2 = bufTripole(iDst,halo%tripoleRows,k) + x1 = bufTripole(i ,halo%tripoleRows,k,l) + x2 = bufTripole(iDst,halo%tripoleRows,k,l) xavg = nint(0.5_dbl_kind*(x1 + isign*x2)) - bufTripole(i ,halo%tripoleRows,k) = xavg - bufTripole(iDst,halo%tripoleRows,k) = isign*xavg + bufTripole(i ,halo%tripoleRows,k,l) = xavg + bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg + end do end do end do @@ -3072,9 +5291,10 @@ subroutine ice_HaloUpdate3DI4(array, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then + do l=1,nt do k=1,nz - array(iDst,jDst,k,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k) + array(iDst,jDst,k,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) + end do end do endif @@ -3083,7 +5303,37 @@ subroutine ice_HaloUpdate3DI4(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -3091,14 +5341,18 @@ end subroutine ice_HaloUpdate3DI4 !*********************************************************************** - subroutine ice_HaloUpdate4DR8(array, halo, & + subroutine ice_HaloUpdate4DR8(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal arrays of double precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -3115,6 +5369,9 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (dbl_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -3125,29 +5382,48 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,l,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam real (dbl_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DR8)' @@ -3174,14 +5450,14 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -3189,95 +5465,183 @@ subroutine ice_HaloUpdate4DR8(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_dbl_kind + fill = 0._dbl_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) nt = size(array, dim=4) nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif !----------------------------------------------------------------------- ! -! do local copies -! if srcBlock is zero, that denotes an eliminated land block or a -! closed boundary where ghost cell values are undefined +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + do l=1,nt + do k=1,nz + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos +! +!----------------------------------------------------------------------- + + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly + +!----------------------------------------------------------------------- +! +! do local copies while waiting for messages to complete +! if srcBlock is zero, that denotes an eliminated land block or a +! closed boundary where ghost cell values are undefined ! if srcBlock is less than zero, the message is a copy out of the ! tripole buffer and will be treated later ! @@ -3293,29 +5657,166 @@ subroutine ice_HaloUpdate4DR8(array, halo, & if (srcBlock > 0) then if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) end do end do - else if (dstBlock < 0) then ! tripole copy into buffer + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else do l=1,nt do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) + array(iDst,jDst,k,l,dstBlock) = fill end do end do endif - else if (srcBlock == 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill - end do - end do endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -3354,7 +5855,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal - i + 2 x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3380,7 +5881,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3418,7 +5919,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3444,7 +5945,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_dbl_kind*(x1 + isign*x2) + xavg = (0.5_dbl_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3490,8 +5991,7 @@ subroutine ice_HaloUpdate4DR8(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -3501,7 +6001,37 @@ subroutine ice_HaloUpdate4DR8(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -3509,14 +6039,18 @@ end subroutine ice_HaloUpdate4DR8 !*********************************************************************** - subroutine ice_HaloUpdate4DR4(array, halo, & + subroutine ice_HaloUpdate4DR4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal arrays of single precision. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -3533,6 +6067,9 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + real (real_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -3543,29 +6080,48 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,l,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (real_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam real (real_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DR4)' @@ -3592,14 +6148,14 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -3607,146 +6163,371 @@ subroutine ice_HaloUpdate4DR4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0.0_real_kind + fill = 0._real_kind + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) nt = size(array, dim=4) nxGlobal = 0 - if (allocated(bufTripoleR4)) then - nxGlobal = size(bufTripoleR4,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif !----------------------------------------------------------------------- ! -! do local copies -! if srcBlock is zero, that denotes an eliminated land block or a -! closed boundary where ghost cell values are undefined -! if srcBlock is less than zero, the message is a copy out of the -! tripole buffer and will be treated later +! post receives ! !----------------------------------------------------------------------- - do nmsg=1,halo%numLocalCopies - iSrc = halo%srcLocalAddr(1,nmsg) - jSrc = halo%srcLocalAddr(2,nmsg) - srcBlock = halo%srcLocalAddr(3,nmsg) - iDst = halo%dstLocalAddr(1,nmsg) - jDst = halo%dstLocalAddr(2,nmsg) - dstBlock = halo%dstLocalAddr(3,nmsg) + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) - if (srcBlock > 0) then - if (dstBlock > 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) - end do - end do - else if (dstBlock < 0) then ! tripole copy into buffer - do l=1,nt - do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) - end do - end do - endif - else if (srcBlock == 0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock) end do end do - endif + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! -! take care of northern boundary in tripole case -! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows -! (T-fold) of physical domain for entire (global) top row +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos ! !----------------------------------------------------------------------- - if (nxGlobal > 0) then + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary - select case (fieldKind) - case (field_type_scalar) - isign = 1 + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly + +!----------------------------------------------------------------------- +! +! do local copies while waiting for messages to complete +! if srcBlock is zero, that denotes an eliminated land block or a +! closed boundary where ghost cell values are undefined +! if srcBlock is less than zero, the message is a copy out of the +! tripole buffer and will be treated later +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numLocalCopies + iSrc = halo%srcLocalAddr(1,nmsg) + jSrc = halo%srcLocalAddr(2,nmsg) + srcBlock = halo%srcLocalAddr(3,nmsg) + iDst = halo%dstLocalAddr(1,nmsg) + jDst = halo%dstLocalAddr(2,nmsg) + dstBlock = halo%dstLocalAddr(3,nmsg) + + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = fill + end do + end do + endif + endif + end do + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + +!----------------------------------------------------------------------- +! +! take care of northern boundary in tripole case +! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows +! (T-fold) of physical domain for entire (global) top row +! +!----------------------------------------------------------------------- + + if (nxGlobal > 0) then + + select case (fieldKind) + case (field_type_scalar) + isign = 1 case (field_type_vector) isign = -1 case (field_type_angle) @@ -3772,7 +6553,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal - i + 2 x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3798,7 +6579,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3836,7 +6617,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3862,7 +6643,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & iDst = nxGlobal + 1 - i x1 = bufTripole(i ,halo%tripoleRows,k,l) x2 = bufTripole(iDst,halo%tripoleRows,k,l) - xavg = 0.5_real_kind*(x1 + isign*x2) + xavg = (0.5_real_kind*(x1 + isign*x2)) bufTripole(i ,halo%tripoleRows,k,l) = xavg bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg end do @@ -3908,8 +6689,7 @@ subroutine ice_HaloUpdate4DR4(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -3919,7 +6699,37 @@ subroutine ice_HaloUpdate4DR4(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -3927,14 +6737,18 @@ end subroutine ice_HaloUpdate4DR4 !*********************************************************************** - subroutine ice_HaloUpdate4DI4(array, halo, & + subroutine ice_HaloUpdate4DI4(array, halo, & fieldLoc, fieldKind, & - fillValue) + fillValue, tripoleOnly) + +! Generated by ./generate_haloUpdates.sh on 2026-02-20 +! This is autogenerated so may have some extra code, like k and l +! loops of length 1 or extra size 1 dimensions in arrays. This is +! done to simply code generation and does not seem to impact performance. ! This routine updates ghost cells for an input array and is a ! member of a group of routines under the generic interface -! ice\_HaloUpdate. This routine is the specific interface -! for 4d horizontal integer arrays. +! ice\_HaloUpdate. type (ice_halo), intent(in) :: & halo ! precomputed halo structure containing all @@ -3951,6 +6765,9 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! (e.g. eliminated land blocks or ! closed boundaries) + logical (log_kind), intent(in), optional :: & + tripoleOnly ! optional flag to execute halo only across tripole seam + integer (int_kind), dimension(:,:,:,:,:), intent(inout) :: & array ! array containing field for which halo ! needs to be updated @@ -3961,29 +6778,48 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! !----------------------------------------------------------------------- - integer (int_kind) :: & - i,j,k,l,nmsg, &! dummy loop indices - iblk,ilo,ihi,jlo,jhi, &! block sizes for fill - iblock,jblock, &! global block indices - nxGlobal, &! global domain size in x (tripole) - nz, nt, &! size of array in 3rd,4th dimensions - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + i,j,k,l,n,nmsg, &! dummy loop indices + ilo,ihi,jlo,jhi, &! block sizes for fill + iblk,iblock,jblock, &! global block indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + nz, nt, &! size of array in 3rd,4th dimensions + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids integer (int_kind) :: & - fill, &! value to use for unknown points - x1,x2,xavg ! scalars for enforcing symmetry at U pts + fill, &! value to use for unknown points + x1,x2,xavg ! scalars for enforcing symmetry at U pts logical (log_kind) :: & - ewfillouter, &! fill outer boundary ew - nsfillouter ! fill outer boundary ns + ewfillouter, &! fill outer boundary ew + nsfillouter, &! fill outer boundary ns + ltripoleOnly ! local flag to execute halo only across tripole seam integer (int_kind), dimension(:,:,:,:), allocatable :: & - bufTripole ! 4d tripole buffer + bufTripole ! 4d tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of message + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate4DI4)' @@ -4010,14 +6846,14 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ! !----------------------------------------------------------------------- - ewfillouter = .false. - nsfillouter = .false. + ewfillouter = .true. + nsfillouter = .true. - ! fill outer boundary if cyclic - if (halo%ewBoundaryType == 'cyclic') ewfillouter=.true. - if (halo%nsBoundaryType == 'tripole' .or. & - halo%nsBoundaryType == 'tripoleT' .or. & - halo%nsBoundaryType == 'cyclic') nsfillouter=.true. + ! do not fill outer boundary if open or closed + if (halo%ewBoundaryType == 'open' .or. & + halo%ewBoundaryType == 'closed') ewfillouter=.false. + if (halo%nsBoundaryType == 'open' .or. & + halo%nsBoundaryType == 'closed') nsfillouter=.false. if (present(fillValue)) then fill = fillValue @@ -4025,144 +6861,369 @@ subroutine ice_HaloUpdate4DI4(array, halo, & ewfillouter = .true. nsfillouter = .true. else - fill = 0_int_kind + fill = 0 + endif + + if (present(tripoleOnly)) then + ltripoleOnly = tripoleOnly + else + ltripoleOnly = .false. endif nz = size(array, dim=3) nt = size(array, dim=4) nxGlobal = 0 - if (allocated(bufTripoleI4)) then - nxGlobal = size(bufTripoleI4,dim=1) - allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt)) + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt),stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole array') + return + endif bufTripole = fill endif +#ifndef SERIAL_REMOVE_MPI !----------------------------------------------------------------------- ! -! Fill out halo region -! Needed for masked halos to ensure halo values are filled for -! halo grid cells that are not updated -! In general, do NOT fill outer boundary for open boundary conditions -! because do not want to overwrite existing data +! allocate request and status arrays for messages +! allocate send/recv buffers ! !----------------------------------------------------------------------- - ! fill outer boundary as needed - ! only fill corners if both edges are being filled - do iblk = 1, halo%numLocalBlocks - call get_block_parameter(halo%blockGlobalID(iblk), & - ilo=ilo, ihi=ihi, & - jlo=jlo, jhi=jhi, & - iblock=iblock, jblock=jblock) - if (ewfillouter .or. iblock > 1) then ! west edge - do i = 1,nghost - array(ilo-i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (ewfillouter .or. iblock < nblocks_x) then ! east edge - do i = 1,nghost - array(ihi+i, jlo:jhi, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock > 1) then ! south edge - do j = 1,nghost - array(ilo:ihi, jlo-j, :, :, iblk) = fill - enddo - endif - if (nsfillouter .or. jblock < nblocks_y) then ! north edge - do j = 1,nghost - array(ilo:ihi, jhi+j, :, :, iblk) = fill - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ilo-i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner - (nsfillouter .or. jblock > 1)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jlo-j, :, :, iblk) = fill - enddo - enddo - endif - if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner - (nsfillouter .or. jblock < nblocks_y)) then - do j = 1,nghost - do i = 1,nghost - array(ihi+i, jhi+j, :, :, iblk) = fill - enddo - enddo - endif - enddo ! iblk + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), & + bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & + stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating buf arrays') + return + endif !----------------------------------------------------------------------- ! -! do local copies -! if srcBlock is zero, that denotes an eliminated land block or a -! closed boundary where ghost cell values are undefined -! if srcBlock is less than zero, the message is a copy out of the -! tripole buffer and will be treated later +! post receives ! !----------------------------------------------------------------------- - do nmsg=1,halo%numLocalCopies - iSrc = halo%srcLocalAddr(1,nmsg) - jSrc = halo%srcLocalAddr(2,nmsg) - srcBlock = halo%srcLocalAddr(3,nmsg) - iDst = halo%dstLocalAddr(1,nmsg) - jDst = halo%dstLocalAddr(2,nmsg) - dstBlock = halo%dstLocalAddr(3,nmsg) + do nmsg=1,halo%numMsgRecv + len = halo%SizeRecv(nmsg)*nz*nt + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + i=0 + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) - if (srcBlock > 0) then - if (dstBlock > 0) then - do l=1,nt - do k=1,nz - array(iDst,jDst,k,l,dstBlock) = & - array(iSrc,jSrc,k,l,srcBlock) - end do - end do - else if (dstBlock < 0) then ! tripole copy into buffer - do l=1,nt - do k=1,nz - bufTripole(iDst,jDst,k,l) = & - array(iSrc,jSrc,k,l,srcBlock) - end do - end do - endif - else if (srcBlock == 0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = fill + i = i + 1 + bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock) end do end do - endif + end do + + do n=i+1,bufSizeSend*nz*nt + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg)*nz*nt + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) end do +#endif !----------------------------------------------------------------------- ! -! take care of northern boundary in tripole case -! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows -! (T-fold) of physical domain for entire (global) top row +! while messages are being communicated, fill out halo region +! needed for masked halos to ensure halo values are filled for +! halo grid cells that are not updated except in cases where +! you don't want to overwrite those halos ! !----------------------------------------------------------------------- - if (nxGlobal > 0) then - - select case (fieldKind) + if (.not. ltripoleOnly) then + ! tripoleOnly skip fill, do not overwrite any values in interior as they may + ! already be set and filling tripole is not necessary + + ! fill outer boundary as needed + ! only fill corners if both edges are being filled + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + if (ewfillouter .or. iblock > 1) then ! west edge + do i = 1,nghost + array(ilo-i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (ewfillouter .or. iblock < nblocks_x) then ! east edge + do i = 1,nghost + array(ihi+i,jlo:jhi,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock > 1) then ! south edge + do j = 1,nghost + array(ilo:ihi,jlo-j,:,:,iblk) = fill + enddo + endif + if (nsfillouter .or. jblock < nblocks_y) then ! north edge + do j = 1,nghost + array(ilo:ihi,jhi+j,:,:,iblk) = fill + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! southwest corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock > 1) .and. & ! northwest corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ilo-i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! southeast corner + (nsfillouter .or. jblock > 1)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jlo-j,:,:,iblk) = fill + enddo + enddo + endif + if ((ewfillouter .or. iblock < nblocks_x) .and. & ! northeast corner + (nsfillouter .or. jblock < nblocks_y)) then + do j = 1,nghost + do i = 1,nghost + array(ihi+i,jhi+j,:,:,iblk) = fill + enddo + enddo + endif + enddo ! iblk + endif ! tripoleonly + +!----------------------------------------------------------------------- +! +! do local copies while waiting for messages to complete +! if srcBlock is zero, that denotes an eliminated land block or a +! closed boundary where ghost cell values are undefined +! if srcBlock is less than zero, the message is a copy out of the +! tripole buffer and will be treated later +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numLocalCopies + iSrc = halo%srcLocalAddr(1,nmsg) + jSrc = halo%srcLocalAddr(2,nmsg) + srcBlock = halo%srcLocalAddr(3,nmsg) + iDst = halo%dstLocalAddr(1,nmsg) + jDst = halo%dstLocalAddr(2,nmsg) + dstBlock = halo%dstLocalAddr(3,nmsg) + + if (srcBlock > 0) then + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (dstBlock < 0) then ! tripole copy into buffer + do l=1,nt + do k=1,nz + bufTripole(iDst,jDst,k,l) = array(iSrc,jSrc,k,l,srcBlock) + end do + end do + endif + else if (srcBlock == 0) then + if (ltripoleOnly) then + ! skip + else + do l=1,nt + do k=1,nz + array(iDst,jDst,k,l,dstBlock) = fill + end do + end do + endif + endif + end do + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + i = 0 + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock > 0) then + if (ltripoleOnly) then + ! skip but still need to advance i counter + i = i + nt*nz + else + do l=1,nt + do k=1,nz + i = i + 1 + array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg) + end do + end do + endif + else if (dstBlock < 0) then !tripole + do l=1,nt + do k=1,nz + i = i + 1 + bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg) + end do + end do + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! Compute zero_gradient and linear_extrap BCs +! BCs in corner can be computed in either direction first +! Do full length of edges in both directions to address edge box corners, those halo points will be +! computed independently for each box. Second pass (north/south) will clean global corners +! Needs to come after halo update because want halo to be filled by other methods (cyclic) first +! before applying zero_gradient/linear_extrap in other direction +! +!----------------------------------------------------------------------- + + if (halo%ewBoundaryType == 'zero_gradient' .or. halo%ewBoundaryType == 'linear_extrap' .or. & + halo%nsBoundaryType == 'zero_gradient' .or. halo%nsBoundaryType == 'linear_extrap') then + do iblk = 1, halo%numLocalBlocks + call get_block_parameter(halo%blockGlobalID(iblk), & + ilo=ilo, ihi=ihi, & + jlo=jlo, jhi=jhi, & + iblock=iblock, jblock=jblock) + + if (iblock == 1) then ! west edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(i,j,:,:,iblk) = array(ilo,j,:,:,iblk) - & + real((nghost-i+1),dbl_kind)*(array(ilo+1,j,:,:,iblk)-array(ilo,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (iblock == nblocks_x) then ! east edge + if (halo%ewBoundaryType == 'zero_gradient' ) then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + enddo + enddo + elseif (halo%ewBoundaryType == 'linear_extrap') then + do j = jlo-nghost,jhi+nghost + do i = 1,nghost + array(ihi+i,j,:,:,iblk) = array(ihi,j,:,:,iblk) + & + real((i),dbl_kind)*(array(ihi,j,:,:,iblk)-array(ihi-1,j,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == 1) then ! south edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,j,:,:,iblk) = array(i,jlo,:,:,iblk) - & + real((nghost-j+1),dbl_kind)*(array(i,jlo+1,:,:,iblk)-array(i,jlo,:,:,iblk)) + enddo + enddo + endif + endif + + if (jblock == nblocks_y) then ! north edge + if (halo%nsBoundaryType == 'zero_gradient' ) then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + enddo + enddo + elseif (halo%nsBoundaryType == 'linear_extrap') then + do j = 1,nghost + do i = ilo-nghost,ihi+nghost + array(i,jhi+j,:,:,iblk) = array(i,jhi,:,:,iblk) + & + real((j),dbl_kind)*(array(i,jhi,:,:,iblk)-array(i,jhi-1,:,:,iblk)) + enddo + enddo + endif + endif + + enddo ! iblk + endif ! zero_gradient or linear_extrap + +!----------------------------------------------------------------------- +! +! take care of northern boundary in tripole case +! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows +! (T-fold) of physical domain for entire (global) top row +! +!----------------------------------------------------------------------- + + if (nxGlobal > 0) then + + select case (fieldKind) case (field_type_scalar) isign = 1 case (field_type_vector) @@ -4326,8 +7387,7 @@ subroutine ice_HaloUpdate4DI4(array, halo, & if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then do l=1,nt do k=1,nz - array(iDst,jDst,k,l,dstBlock) = isign* & - bufTripole(iSrc,jSrc,k,l) + array(iDst,jDst,k,l,dstBlock) = isign*bufTripole(iSrc,jSrc,k,l) end do end do endif @@ -4337,7 +7397,37 @@ subroutine ice_HaloUpdate4DI4(array, halo, & endif - if (allocated(bufTripole)) deallocate(bufTripole) +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) + + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif + + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating send,recv buf arrays') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole array') + return + endif + endif !----------------------------------------------------------------------- @@ -4368,25 +7458,47 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & ! closed boundaries) real (dbl_kind), dimension(:,:,:), intent(inout) :: & - array1 ,& ! array containing field for which halo + array1, &! array containing field for which halo ! needs to be updated array2 ! array containing field for which halo ! in array1 needs to be updated ! local variables - integer (int_kind) :: & - nmsg, &! dummy loop indices - nxGlobal, &! global domain size in x (tripole) - iSrc,jSrc, &! source addresses for message - iDst,jDst, &! dest addresses for message - srcBlock, &! local block number for source - dstBlock, &! local block number for destination - ioffset, joffset, &! address shifts for tripole - isign ! sign factor for tripole grids + integer (int_kind) :: & + n,nmsg, &! dummy loop indices + istat, &! allocate status flag + nxGlobal, &! global domain size in x (tripole) + iSrc,jSrc, &! source addresses for message + iDst,jDst, &! dest addresses for message + srcBlock, &! local block number for source + dstBlock, &! local block number for destination + ioffset, joffset, &! address shifts for tripole + isign ! sign factor for tripole grids real (dbl_kind) :: & - fill ! value to use for unknown points + fill ! value to use for unknown points + + real (dbl_kind), dimension(:,:), allocatable :: & + bufTripole ! tripole buffer + +#ifndef SERIAL_REMOVE_MPI + integer (int_kind) :: & + ierr, &! error or status flag for MPI,alloc + len ! length of messages + + + integer (int_kind), dimension(:), allocatable :: & + sndRequest, &! MPI request ids + rcvRequest ! MPI request ids + + integer (int_kind), dimension(:,:), allocatable :: & + sndStatus, &! MPI status flags + rcvStatus ! MPI status flags + + real (dbl_kind), dimension(:,:), allocatable :: & + bufSend, bufRecv ! 4d send,recv buffers +#endif character(len=*), parameter :: subname = '(ice_HaloUpdate_stress)' @@ -4420,34 +7532,95 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & endif nxGlobal = 0 - if (allocated(bufTripoleR8)) then - nxGlobal = size(bufTripoleR8,dim=1) - bufTripoleR8 = fill + if (nxGlobal_size > 0) then + nxGlobal = nxGlobal_size + allocate(bufTripole(nxGlobal,halo%tripoleRows), stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufTripole arrays') + return + endif + bufTripole = fill + endif + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! allocate request and status arrays for messages +! +!----------------------------------------------------------------------- + + allocate(sndRequest(halo%numMsgSend), & + rcvRequest(halo%numMsgRecv), & + sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & + rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating req,status arrays') + return + endif + + allocate(bufSend(bufSizeSend, halo%numMsgSend), & + bufRecv(bufSizeRecv, halo%numMsgRecv), stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: allocating bufSend, bufRecv') + return endif !----------------------------------------------------------------------- ! +! post receives +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgRecv + + len = halo%SizeRecv(nmsg) + call MPI_IRECV(bufRecv(1,nmsg), len, mpiR8, & + halo%recvTask(nmsg), & + mpitagHalo + halo%recvTask(nmsg), & + halo%communicator, rcvRequest(nmsg), ierr) + end do + +!----------------------------------------------------------------------- +! +! fill send buffer and post sends +! +!----------------------------------------------------------------------- + + do nmsg=1,halo%numMsgSend + + do n=1,halo%sizeSend(nmsg) + iSrc = halo%sendAddr(1,n,nmsg) + jSrc = halo%sendAddr(2,n,nmsg) + srcBlock = halo%sendAddr(3,n,nmsg) + + bufSend(n,nmsg) = array2(iSrc,jSrc,srcBlock) + end do + do n=halo%sizeSend(nmsg)+1,bufSizeSend + bufSend(n,nmsg) = fill ! fill remainder of buffer + end do + + len = halo%SizeSend(nmsg) + call MPI_ISEND(bufSend(1,nmsg), len, mpiR8, & + halo%sendTask(nmsg), & + mpitagHalo + my_task, & + halo%communicator, sndRequest(nmsg), ierr) + end do +#endif + +!----------------------------------------------------------------------- +! +! while messages are being communicated, ! do NOT zero the halo out, this halo update just updates ! the tripole zipper as needed for stresses. if you zero ! it out, all halo values will be wiped out. +! !----------------------------------------------------------------------- -! do iblk = 1, halo%numLocalBlocks -! call get_block_parameter(halo%blockGlobalID(iblk), & -! ilo=ilo, ihi=ihi, & -! jlo=jlo, jhi=jhi) -! do j = 1,nghost -! array(1:nx_block, jlo-j,iblk) = fill -! array(1:nx_block, jhi+j,iblk) = fill -! enddo -! do i = 1,nghost -! array(ilo-i, 1:ny_block,iblk) = fill -! array(ihi+i, 1:ny_block,iblk) = fill -! enddo -! enddo !----------------------------------------------------------------------- ! -! do local copies +! do local copies while waiting for messages to complete ! if srcBlock is zero, that denotes an eliminated land block or a ! closed boundary where ghost cell values are undefined ! if srcBlock is less than zero, the message is a copy out of the @@ -4465,14 +7638,42 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & if (srcBlock > 0) then if (dstBlock < 0) then ! tripole copy into buffer - bufTripoleR8(iDst,jDst) = & - array2(iSrc,jSrc,srcBlock) + bufTripole(iDst,jDst) = array2(iSrc,jSrc,srcBlock) endif else if (srcBlock == 0) then array1(iDst,jDst,dstBlock) = fill endif end do +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! wait for receives to finish and then unpack the recv buffer into +! ghost cells +! +!----------------------------------------------------------------------- + + call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr) + + do nmsg=1,halo%numMsgRecv + do n=1,halo%sizeRecv(nmsg) + iDst = halo%recvAddr(1,n,nmsg) + jDst = halo%recvAddr(2,n,nmsg) + dstBlock = halo%recvAddr(3,n,nmsg) + + if (dstBlock < 0) then !tripole + bufTripole(iDst,jDst) = bufRecv(n,nmsg) + endif + end do + end do +#endif + +!----------------------------------------------------------------------- +! +! No special code for zero_gradient or linear_extrap bcs, only a tripole update +! +!----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ! take care of northern boundary in tripole case @@ -4580,7 +7781,7 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & !*** otherwise do the copy if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then - array1(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc) + array1(iDst,jDst,dstBlock) = isign*bufTripole(iSrc,jSrc) endif endif @@ -4589,18 +7790,50 @@ subroutine ice_HaloUpdate_stress(array1, array2, halo, & endif !----------------------------------------------------------------------- +! +! wait for sends to complete and deallocate arrays +! +!----------------------------------------------------------------------- - end subroutine ice_HaloUpdate_stress +#ifndef SERIAL_REMOVE_MPI + call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr) -!*********************************************************************** + deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=istat) - subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, & - srcProc, dstProc, msgSize) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating req,status arrays') + return + endif -! This is a utility routine to increment the arrays for counting -! whether messages are required. It checks the source and destination -! task to see whether the current task needs to send, receive or -! copy messages to fill halo regions (ghost cells). + deallocate(bufSend, bufRecv, stat=istat) + + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufSend, bufRecv') + return + endif +#endif + + if (allocated(bufTripole)) then + deallocate(bufTripole, stat=istat) + if (istat > 0) then + call abort_ice(subname//'ERROR: deallocating bufTripole') + return + endif + endif + +!----------------------------------------------------------------------- + + end subroutine ice_HaloUpdate_stress + +!*********************************************************************** + + subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, & + srcProc, dstProc, msgSize) + +! This is a utility routine to increment the arrays for counting +! whether messages are required. It checks the source and destination +! task to see whether the current task needs to send, receive or +! copy messages to fill halo regions (ghost cells). integer (int_kind), intent(in) :: & srcProc, &! source processor for communication @@ -4642,8 +7875,9 @@ subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, & ! !----------------------------------------------------------------------- - if (srcProc == my_task + 1) sndCounter(dstProc) = & - sndCounter(dstProc) + msgSize + if (srcProc == my_task + 1) then + sndCounter(dstProc) = sndCounter(dstProc) + msgSize + endif !----------------------------------------------------------------------- ! @@ -4680,18 +7914,18 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) ! message information for a particular pair of blocks. type (distrb), intent(in) :: & - dist ! distribution of blocks across procs + dist ! distribution of blocks across procs integer (int_kind), intent(in) :: & - srcBlock, dstBlock ! source,destination block id + srcBlock, dstBlock ! source,destination block id character (*), intent(in) :: & - direction ! direction of neighbor block - ! (north,south,east,west, - ! and NE, NW, SE, SW) + direction ! direction of neighbor block + ! (north,south,east,west, + ! and NE, NW, SE, SW) type (ice_halo), intent(inout) :: & - halo ! data structure containing halo info + halo ! data structure containing halo info !----------------------------------------------------------------------- ! @@ -4701,12 +7935,13 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) integer (int_kind) :: & srcProc, srcLocalID, &! source block location in distribution - dstProc, dstLocalID, &! source block location in distribution + dstProc, dstLocalID, &! destination block location in distribution msgIndx, &! message counter and index into msg array ibSrc, ieSrc, jbSrc, jeSrc, &! phys domain info for source block ibDst, ieDst, jbDst, jeDst, &! phys domain info for dest block nxGlobal, &! size of global domain in e-w direction - i,j ! dummy loop index + bufSize, &! size of message buffer + i,j,n ! dummy loop index integer (int_kind), dimension(:), pointer :: & iGlobal ! global i index for location in tripole @@ -4719,7 +7954,7 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) ! !----------------------------------------------------------------------- - if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1) + nxGlobal = nxGlobal_size !----------------------------------------------------------------------- ! @@ -4791,14 +8026,20 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) !*** compute addresses based on direction + msgIndx = halo%numLocalCopies + + if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & + msgIndx > size(halo%dstLocalAddr,dim=2)) then + call abort_ice(subname//'ERROR: msg count 1 > array size') + return + endif + select case (direction) case ('east') !*** copy easternmost physical domain of src !*** into westernmost halo of dst - msgIndx = halo%numLocalCopies - do j=1,jeSrc-jbSrc+1 do i=1,nghost @@ -4815,15 +8056,11 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) end do end do - halo%numLocalCopies = msgIndx - case ('west') !*** copy westernmost physical domain of src !*** into easternmost halo of dst - msgIndx = halo%numLocalCopies - do j=1,jeSrc-jbSrc+1 do i=1,nghost @@ -4840,8 +8077,6 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) end do end do - halo%numLocalCopies = msgIndx - case ('north') !*** copy northern physical domain of src @@ -4849,8 +8084,6 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) if (srcBlock > 0 .and. dstBlock > 0) then ! normal north boundary - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,ieSrc-ibSrc+1 @@ -4867,72 +8100,529 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) end do end do - halo%numLocalCopies = msgIndx - else if (srcBlock > 0 .and. dstBlock < 0) then - !*** tripole grid - copy info into tripole buffer - !*** copy physical domain of top halo+1 rows - !*** into global buffer at src location + !*** tripole grid - copy info into tripole buffer + !*** copy physical domain of top halo+1 rows + !*** into global buffer at src location + + !*** perform an error check to make sure the + !*** block has enough points to perform a tripole + !*** update + + if (jeSrc - jbSrc + 1 < halo%tripoleRows) then + call abort_ice(subname//'ERROR: not enough points in block for tripole') + return + endif + + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 + halo%srcLocalAddr(2,msgIndx) = jeSrc-halo%tripoleRows+j + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1) + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = -dstLocalID + + end do + end do + + else if (srcBlock < 0 .and. dstBlock > 0) then + + !*** tripole grid - set up for copying out of + !*** tripole buffer into ghost cell domains + !*** include e-w ghost cells + + do j=1,halo%tripoleRows + do i=1,ieSrc+nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1 + halo%srcLocalAddr(2,msgIndx) = nghost + 3 - j + halo%srcLocalAddr(3,msgIndx) = -srcLocalID + + halo%dstLocalAddr(1,msgIndx) = i + if (j.gt.nghost+1) then + halo%dstLocalAddr(2,msgIndx) = -1 ! never used + else + halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1 + endif + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + endif + + case ('south') + + !*** copy southern physical domain of src + !*** into northern halo of dst + + do j=1,nghost + do i=1,ieSrc-ibSrc+1 + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 + halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('northeast') + + !*** normal northeast boundary - just copy NE corner + !*** of physical domain into SW halo of NE nbr block + + if (dstBlock > 0) then + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i + halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = i + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + else + + !*** tripole grid - this local copy should already + !*** have taken place for the north boundary + + endif + + case ('northwest') + + !*** normal northeast boundary - just copy NW corner + !*** of physical domain into SE halo of NW nbr block + + if (dstBlock > 0) then + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 + halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = ieDst + i + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + else + + !*** tripole grid - this local copy should already + !*** have taken place for the north boundary + + endif + + case ('southeast') + + !*** copy southeastern corner of src physical domain + !*** into northwestern halo of dst + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i + halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = i + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('southwest') + + !*** copy southwestern corner of src physical domain + !*** into northeastern halo of dst + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 + halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 + halo%srcLocalAddr(3,msgIndx) = srcLocalID + + halo%dstLocalAddr(1,msgIndx) = ieDst + i + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case default + + call abort_ice(subname//'ERROR: unknown direction local copy') + return + + end select + + halo%numLocalCopies = msgIndx + + if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & + msgIndx > size(halo%dstLocalAddr,dim=2)) then + call abort_ice(subname//'ERROR: msg count 2 > array size') + return + endif + +!----------------------------------------------------------------------- +! +! if dest block is local and source block does not exist, create a +! local copy to fill halo with a fill value +! +!----------------------------------------------------------------------- + + else if (srcProc == 0 .and. dstProc == my_task+1) then + + msgIndx = halo%numLocalCopies + + if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & + msgIndx > size(halo%dstLocalAddr,dim=2)) then + call abort_ice(subname//'ERROR: msg count 3 > array size') + return + endif + + !*** compute addresses based on direction + + select case (direction) + case ('east') + + !*** copy easternmost physical domain of src + !*** into westernmost halo of dst + + do j=1,jeSrc-jbSrc+1 + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = i + halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1 + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('west') + + !*** copy westernmost physical domain of src + !*** into easternmost halo of dst + + do j=1,jeSrc-jbSrc+1 + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = ieDst + i + halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1 + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('north') + + !*** copy northern physical domain of src + !*** into southern halo of dst + + if (dstBlock > 0) then ! normal north boundary + + do j=1,nghost + do i=1,ieSrc-ibSrc+1 + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + endif + + case ('south') + + !*** copy southern physical domain of src + !*** into northern halo of dst + + do j=1,nghost + do i=1,ieSrc-ibSrc+1 + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('northeast') + + !*** normal northeast boundary - just copy NE corner + !*** of physical domain into SW halo of NE nbr block + + if (dstBlock > 0) then + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = i + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + endif + + case ('northwest') + + !*** normal northeast boundary - just copy NW corner + !*** of physical domain into SE halo of NW nbr block + + if (dstBlock > 0) then + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = ieDst + i + halo%dstLocalAddr(2,msgIndx) = j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + endif + + case ('southeast') + + !*** copy southeastern corner of src physical domain + !*** into northwestern halo of dst + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = i + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case ('southwest') + + !*** copy southwestern corner of src physical domain + !*** into northeastern halo of dst + + do j=1,nghost + do i=1,nghost + + msgIndx = msgIndx + 1 + + halo%srcLocalAddr(1,msgIndx) = 0 + halo%srcLocalAddr(2,msgIndx) = 0 + halo%srcLocalAddr(3,msgIndx) = 0 + + halo%dstLocalAddr(1,msgIndx) = ieDst + i + halo%dstLocalAddr(2,msgIndx) = jeDst + j + halo%dstLocalAddr(3,msgIndx) = dstLocalID + + end do + end do + + case default + + call abort_ice(subname//'ERROR: unknown direction local copy') + return + + end select + + halo%numLocalCopies = msgIndx + + if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. & + msgIndx > size(halo%dstLocalAddr,dim=2)) then + call abort_ice(subname//'ERROR: msg count 4 > array size') + return + endif + +#ifndef SERIAL_REMOVE_MPI +!----------------------------------------------------------------------- +! +! if source block local and dest block remote, send a message +! +!----------------------------------------------------------------------- + + else if (srcProc == my_task+1 .and. & + dstProc /= my_task+1 .and. dstProc > 0) then + + !*** first check to see if a message to this processor has + !*** already been defined + !*** if not, update counters and indices + + msgIndx = 0 + + srchSend: do n=1,halo%numMsgSend + if (halo%sendTask(n) == dstProc - 1) then + msgIndx = n + bufSize = halo%sizeSend(n) + exit srchSend + endif + end do srchSend + + if (msgIndx == 0) then + msgIndx = halo%numMsgSend + 1 + halo%numMsgSend = msgIndx + halo%sendTask(msgIndx) = dstProc - 1 + bufSize = 0 + endif + + !*** now compute message info based on msg direction + + select case (direction) + case ('east') + + !*** send easternmost physical domain of src + !*** into westernmost halo of dst + + do j=1,jeSrc-jbSrc+1 + do i=1,nghost + + bufSize = bufSize + 1 + + halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i + halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1 + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID + + end do + end do + + halo%sizeSend(msgIndx) = bufSize + + case ('west') + + !*** copy westernmost physical domain of src + !*** into easternmost halo of dst + + do j=1,jeSrc-jbSrc+1 + do i=1,nghost + + bufSize = bufSize + 1 + + halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1 + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID + + end do + end do + + halo%sizeSend(msgIndx) = bufSize - !*** perform an error check to make sure the - !*** block has enough points to perform a tripole - !*** update + case ('north') - if (jeSrc - jbSrc + 1 < halo%tripoleRows) then - call abort_ice(subname//'ERROR: not enough points in block for tripole') - return - endif + if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** copy northern physical domain of src + !*** into southern halo of dst - do j=1,halo%tripoleRows + do j=1,nghost do i=1,ieSrc-ibSrc+1 - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 - halo%srcLocalAddr(2,msgIndx) = jeSrc-halo%tripoleRows+j - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1) - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = -dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize - else if (srcBlock < 0 .and. dstBlock > 0) then - - !*** tripole grid - set up for copying out of - !*** tripole buffer into ghost cell domains - !*** include e-w ghost cells + else - msgIndx = halo%numLocalCopies + !*** tripole block - send top halo%tripoleRows rows of phys domain + halo%tripSend(msgIndx) = 1 do j=1,halo%tripoleRows - do i=1,ieSrc+nghost - - msgIndx = msgIndx + 1 + do i=1,ieSrc-ibSrc+1 - halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1 - halo%srcLocalAddr(2,msgIndx) = nghost + 3 - j - halo%srcLocalAddr(3,msgIndx) = -srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = i - if (j.gt.nghost+1) then - halo%dstLocalAddr(2,msgIndx) = -1 ! never used - else - halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1 - endif - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j + halo%sendAddr(3,bufSize,msgIndx)=srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize endif @@ -4941,133 +8631,104 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) !*** copy southern physical domain of src !*** into northern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,ieSrc-ibSrc+1 - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 - halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1 + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize case ('northeast') - !*** normal northeast boundary - just copy NE corner - !*** of physical domain into SW halo of NE nbr block if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** normal northeast corner + !*** copy northeast corner of src physical domain + !*** into southwestern halo of dst do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i - halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = i - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ieSrc-nghost+i + halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize -! tcx,tcraig, 3/2023, this is not needed -! else -! -! !*** tripole grid - copy entire top halo+1 -! !*** rows into global buffer at src location -! -! msgIndx = halo%numLocalCopies -! -! do j=1,nghost+1 -! do i=1,ieSrc-ibSrc+1 -! -! msgIndx = msgIndx + 1 -! -! halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 -! halo%srcLocalAddr(2,msgIndx) = jeSrc-1-nghost+j -! halo%srcLocalAddr(3,msgIndx) = srcLocalID -! -! halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1) -! halo%dstLocalAddr(2,msgIndx) = j -! halo%dstLocalAddr(3,msgIndx) = -dstLocalID -! -! end do -! end do -! -! halo%numLocalCopies = msgIndx + else + + !*** tripole block - send top halo%tripoleRows rows of phys domain + + halo%tripSend(msgIndx) = 1 + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + bufSize = bufSize + 1 + + halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j + halo%sendAddr(3,bufSize,msgIndx)=srcLocalID + + end do + end do + + halo%sizeSend(msgIndx) = bufSize endif case ('northwest') - !*** normal northwest boundary - just copy NW corner - !*** of physical domain into SE halo of NW nbr block - if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** normal northwest corner + !*** copy northwest corner of src physical domain + !*** into southeastern halo of dst do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 - halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ieDst + i - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize -! tcx,tcraig, 3/2023, this is not needed -! else -! -! !*** tripole grid - copy entire top halo+1 -! !*** rows into global buffer at src location -! -! msgIndx = halo%numLocalCopies -! -! do j=1,nghost+1 -! do i=1,ieSrc-ibSrc+1 -! -! msgIndx = msgIndx + 1 -! -! halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 -! halo%srcLocalAddr(2,msgIndx) = jeSrc-1-nghost+j -! halo%srcLocalAddr(3,msgIndx) = srcLocalID -! -! halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1) -! halo%dstLocalAddr(2,msgIndx) = j -! halo%dstLocalAddr(3,msgIndx) = -dstLocalID -! -! end do -! end do -! -! halo%numLocalCopies = msgIndx + else + + !*** tripole block - send top halo%tripoleRows rows of phys domain + + halo%tripSend(msgIndx) = 1 + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + bufSize = bufSize + 1 + + halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j + halo%sendAddr(3,bufSize,msgIndx)=srcLocalID + + end do + end do + + halo%sizeSend(msgIndx) = bufSize endif @@ -5076,146 +8737,155 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) !*** copy southeastern corner of src physical domain !*** into northwestern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i - halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = i - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i + halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1 + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize case ('southwest') !*** copy southwestern corner of src physical domain !*** into northeastern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1 - halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1 - halo%srcLocalAddr(3,msgIndx) = srcLocalID + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ieDst + i - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1 + halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1 + halo%sendAddr(3,bufSize,msgIndx) = srcLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeSend(msgIndx) = bufSize case default - call abort_ice(subname//'ERROR: unknown direction local copy') - return + !*** already checked in previous case construct end select !----------------------------------------------------------------------- ! -! if dest block is local and source block does not exist, create a -! local copy to fill halo with a fill value +! if source block remote and dest block local, recv a message ! !----------------------------------------------------------------------- - else if (srcProc == 0 .and. dstProc == my_task+1) then + else if (dstProc == my_task+1 .and. & + srcProc /= my_task+1 .and. srcProc > 0) then - !*** compute addresses based on direction + !*** first check to see if a message from this processor has + !*** already been defined + !*** if not, update counters and indices + + msgIndx = 0 + + srchRecv: do n=1,halo%numMsgRecv + if (halo%recvTask(n) == srcProc - 1) then + msgIndx = n + bufSize = halo%sizeRecv(n) + exit srchRecv + endif + end do srchRecv + + if (msgIndx == 0) then + msgIndx = halo%numMsgRecv + 1 + halo%numMsgRecv = msgIndx + halo%recvTask(msgIndx) = srcProc - 1 + bufSize = 0 + endif + + !*** now compute message info based on msg direction select case (direction) case ('east') - !*** copy easternmost physical domain of src + !*** send easternmost physical domain of src !*** into westernmost halo of dst - msgIndx = halo%numLocalCopies - do j=1,jeSrc-jbSrc+1 do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = i - halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1 - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%recvAddr(1,bufSize,msgIndx) = i + halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1 + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize case ('west') !*** copy westernmost physical domain of src !*** into easternmost halo of dst - msgIndx = halo%numLocalCopies - do j=1,jeSrc-jbSrc+1 do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ieDst + i - halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1 - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%recvAddr(1,bufSize,msgIndx) = ieDst + i + halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1 + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize case ('north') - !*** copy northern physical domain of src - !*** into southern halo of dst - - if (dstBlock > 0) then ! normal north boundary + if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** copy northern physical domain of src + !*** into southern halo of dst do j=1,nghost - do i=1,ieSrc-ibSrc+1 + do i=1,ieDst-ibDst+1 - msgIndx = msgIndx + 1 + bufSize = bufSize + 1 - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1 + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID - halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + end do + end do + + halo%sizeRecv(msgIndx) = bufSize + + else + + !*** tripole block - receive into tripole buffer + + halo%tripRecv(msgIndx) = 1 + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + bufSize = bufSize + 1 + + halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1) + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize endif @@ -5224,81 +8894,103 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) !*** copy southern physical domain of src !*** into northern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,ieSrc-ibSrc+1 - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1 - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1 + halo%recvAddr(2,bufSize,msgIndx) = jeDst + j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize case ('northeast') - !*** normal northeast boundary - just copy NE corner - !*** of physical domain into SW halo of NE nbr block - if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** normal northeast neighbor + !*** copy northeast physical domain into + !*** into southwest halo of dst do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 + bufSize = bufSize + 1 - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + halo%recvAddr(1,bufSize,msgIndx) = i + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID - halo%dstLocalAddr(1,msgIndx) = i - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + end do + end do + + halo%sizeRecv(msgIndx) = bufSize + + else + + !*** tripole block - receive into tripole buffer + + halo%tripRecv(msgIndx) = 1 + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + bufSize = bufSize + 1 + + halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1) + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize endif case ('northwest') - !*** normal northwest boundary - just copy NW corner - !*** of physical domain into SE halo of NW nbr block - if (dstBlock > 0) then - msgIndx = halo%numLocalCopies + !*** normal northwest neighbor + !*** copy northwest physical domain into + !*** into southeast halo of dst do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 + bufSize = bufSize + 1 - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + halo%recvAddr(1,bufSize,msgIndx) = ieDst + i + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID - halo%dstLocalAddr(1,msgIndx) = ieDst + i - halo%dstLocalAddr(2,msgIndx) = j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + end do + end do + + halo%sizeRecv(msgIndx) = bufSize + + else + + !*** tripole block - receive into tripole buffer + + halo%tripRecv(msgIndx) = 1 + do j=1,halo%tripoleRows + do i=1,ieSrc-ibSrc+1 + + bufSize = bufSize + 1 + + halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1) + halo%recvAddr(2,bufSize,msgIndx) = j + halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize endif @@ -5307,57 +8999,45 @@ subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction) !*** copy southeastern corner of src physical domain !*** into northwestern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = i - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%recvAddr(1,bufSize,msgIndx) = i + halo%recvAddr(2,bufSize,msgIndx) = jeDst + j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize case ('southwest') !*** copy southwestern corner of src physical domain !*** into northeastern halo of dst - msgIndx = halo%numLocalCopies - do j=1,nghost do i=1,nghost - msgIndx = msgIndx + 1 - - halo%srcLocalAddr(1,msgIndx) = 0 - halo%srcLocalAddr(2,msgIndx) = 0 - halo%srcLocalAddr(3,msgIndx) = 0 + bufSize = bufSize + 1 - halo%dstLocalAddr(1,msgIndx) = ieDst + i - halo%dstLocalAddr(2,msgIndx) = jeDst + j - halo%dstLocalAddr(3,msgIndx) = dstLocalID + halo%recvAddr(1,bufSize,msgIndx) = ieDst + i + halo%recvAddr(2,bufSize,msgIndx) = jeDst + j + halo%recvAddr(3,bufSize,msgIndx) = dstLocalID end do end do - halo%numLocalCopies = msgIndx + halo%sizeRecv(msgIndx) = bufSize case default - call abort_ice(subname//'ERROR: unknown direction local copy') - return + !*** already checked in previous case construct end select +#endif !----------------------------------------------------------------------- ! @@ -5378,8 +9058,7 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) ! This subroutine extrapolates ARRAY values into the ghost cells, ! and is intended for grid variables whose ghost cells -! would otherwise be set using the default boundary conditions (Dirichlet -! or Neumann). +! would otherwise be set using the default boundary conditions. ! ! This is the specific interface for double precision arrays ! corresponding to the generic interface ice_HaloExtrapolate @@ -5439,18 +9118,18 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) if (trim(ew_bndy_type) /= 'cyclic') then do n = 1, nghost ii = ilo - n ! gridcell to extrapolate to - do j = 1, ny_block + do j = jlo-nghost, jhi+nghost ARRAY(ii,j,iblk) = c2*ARRAY(ii+1,j,iblk) - ARRAY(ii+2,j,iblk) enddo enddo endif endif - if (this_block%iblock == nblocks_x) then ! east edge + if (this_block%iblock == nblocks_x) then ! east edge if (trim(ew_bndy_type) /= 'cyclic') then do n = 1, nghost ii = ihi + n ! gridcell to extrapolate to - do j = 1, ny_block + do j = jlo-nghost, jhi+nghost ARRAY(ii,j,iblk) = c2*ARRAY(ii-1,j,iblk) - ARRAY(ii-2,j,iblk) enddo enddo @@ -5461,20 +9140,20 @@ subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type) if (trim(ns_bndy_type) /= 'cyclic') then do n = 1, nghost jj = jlo - n ! gridcell to extrapolate to - do i = 1, nx_block + do i = ilo-nghost, ihi+nghost ARRAY(i,jj,iblk) = c2*ARRAY(i,jj+1,iblk) - ARRAY(i,jj+2,iblk) enddo enddo endif endif - if (this_block%jblock == nblocks_y) then ! north edge + if (this_block%jblock == nblocks_y) then ! north edge if (trim(ns_bndy_type) /= 'cyclic' .and. & trim(ns_bndy_type) /= 'tripole' .and. & trim(ns_bndy_type) /= 'tripoleT' ) then do n = 1, nghost jj = jhi + n ! gridcell to extrapolate to - do i = 1, nx_block + do i = ilo-nghost, ihi+nghost ARRAY(i,jj,iblk) = c2*ARRAY(i,jj-1,iblk) - ARRAY(i,jj-2,iblk) enddo enddo @@ -5498,11 +9177,10 @@ subroutine ice_HaloDestroy(halo) type (ice_halo) :: & halo ! a new halo type with info for halo updates - integer (int_kind) :: & - istat ! error or status flag for MPI,alloc + integer (int_kind) :: & + istat ! error or status flag for MPI,alloc character(len=*), parameter :: subname = '(ice_HaloDestroy)' - !----------------------------------------------------------------------- deallocate(halo%srcLocalAddr, & @@ -5510,9 +9188,25 @@ subroutine ice_HaloDestroy(halo) halo%blockGlobalID, stat=istat) if (istat > 0) then - call abort_ice(subname,' ERROR: deallocating') + call abort_ice(subname,' ERROR: deallocating src,dst') + return + endif + +#ifndef SERIAL_REMOVE_MPI + deallocate(halo%sendTask, & + halo%recvTask, & + halo%sizeSend, & + halo%sizeRecv, & + halo%tripSend, & + halo%tripRecv, & + halo%sendAddr, & + halo%recvAddr, stat=istat) + + if (istat > 0) then + call abort_ice(subname,' ERROR: deallocating send,recv') return endif +#endif end subroutine ice_HaloDestroy diff --git a/cicecore/cicedyn/infrastructure/ice_blocks.F90 b/cicecore/cicedyn/infrastructure/ice_blocks.F90 index 245f77bc7..78b407184 100644 --- a/cicecore/cicedyn/infrastructure/ice_blocks.F90 +++ b/cicecore/cicedyn/infrastructure/ice_blocks.F90 @@ -216,7 +216,7 @@ subroutine create_blocks(nx_global, ny_global, ew_boundary_type, & if (jblock == nblocks_y .and. & (ns_boundary_type == 'tripole' .or. & - ns_boundary_type == 'tripoleT')) then + ns_boundary_type == 'tripoleT')) then all_blocks(n)%tripole = .true. else all_blocks(n)%tripole = .false. @@ -234,16 +234,8 @@ subroutine create_blocks(nx_global, ny_global, ew_boundary_type, & select case (ns_boundary_type) case ('cyclic') j_global(j,n) = j_global(j,n) + ny_global - case ('open') - ! lower to upper - case ('closed') - ! lower to upper - case ('tripole') - ! lower to upper - case ('tripoleT') - ! lower to upper case default - call abort_ice(subname//' ERROR: unknown n-s bndy type') + ! lower to upper end select endif @@ -258,16 +250,12 @@ subroutine create_blocks(nx_global, ny_global, ew_boundary_type, & select case (ns_boundary_type) case ('cyclic') j_global(j,n) = j_global(j,n) - ny_global - case ('open') - ! lower to upper - case ('closed') - ! lower to upper case ('tripole') j_global(j,n) = -j_global(j,n) ! negative case ('tripoleT') j_global(j,n) = -j_global(j,n) ! negative case default - call abort_ice(subname//' ERROR: unknown n-s bndy type') + ! lower to upper end select !*** set last physical point if padded domain @@ -290,12 +278,8 @@ subroutine create_blocks(nx_global, ny_global, ew_boundary_type, & select case (ew_boundary_type) case ('cyclic') i_global(i,n) = i_global(i,n) + nx_global - case ('open') - ! left to right - case ('closed') - ! left to right case default - call abort_ice(subname//' ERROR: unknown e-w bndy type') + ! left to right end select endif @@ -310,12 +294,8 @@ subroutine create_blocks(nx_global, ny_global, ew_boundary_type, & select case (ew_boundary_type) case ('cyclic') i_global(i,n) = i_global(i,n) - nx_global - case ('open') - ! left to right - case ('closed') - ! left to right case default - call abort_ice(subname//' ERROR: unknown e-w bndy type') + ! left to right end select !*** last physical point in padded domain @@ -431,10 +411,6 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock + 1 if (jnbr > nblocks_y) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = 1 case ('tripole':'tripoleT') @@ -447,7 +423,7 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & inbr = nblocks_x - iBlock + 1 jnbr = -jBlock case default - call abort_ice(subname//' ERROR: unknown north boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -457,18 +433,10 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock - 1 if (jnbr < 1) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = nblocks_y - case ('tripole') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('tripoleT') - jnbr = 0 ! do not write into the neighbor's ghost cells case default - call abort_ice(subname//' ERROR: unknown south boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -478,14 +446,10 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock if (inbr > nblocks_x) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = 1 case default - call abort_ice(subname//' ERROR: unknown east boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -495,14 +459,10 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & inbr = iBlock - 1 if (inbr < 1) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = nblocks_x case default - call abort_ice(subname//' ERROR: unknown west boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -512,22 +472,14 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock + 1 if (inbr > nblocks_x) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = 1 case default - call abort_ice(subname//' ERROR: unknown east boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr > nblocks_y) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = 1 case ('tripole':'tripoleT') @@ -541,7 +493,7 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & if (inbr == 0) inbr = nblocks_x jnbr = -jBlock case default - call abort_ice(subname//' ERROR: unknown north boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -551,22 +503,14 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock + 1 if (inbr < 1) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = nblocks_x case default - call abort_ice(subname//' ERROR: unknown west boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr > nblocks_y) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = 1 case ('tripole':'tripoleT') @@ -580,7 +524,7 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & if (inbr > nblocks_x) inbr = 1 jnbr = -jBlock case default - call abort_ice(subname//' ERROR: unknown north boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -590,30 +534,18 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock - 1 if (inbr > nblocks_x) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = 1 case default - call abort_ice(subname//' ERROR: unknown east boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr < 1) then select case(jBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = nblocks_y - case ('tripole') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('tripoleT') - jnbr = 0 ! do not write into the neighbor's ghost cells case default - call abort_ice(subname//' ERROR: unknown south boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -622,30 +554,18 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock - 1 if (inbr < 1) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = nblocks_x case default - call abort_ice(subname//' ERROR: unknown west boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr < 1) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = nblocks_y - case ('tripole') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('tripoleT') - jnbr = 0 ! do not write into the neighbor's ghost cells case default - call abort_ice(subname//' ERROR: unknown south boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -655,14 +575,10 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock if (inbr > nblocks_x) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = inbr - nblocks_x case default - call abort_ice(subname//' ERROR: unknown east boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -671,14 +587,10 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & inbr = iBlock - 2 if (inbr < 1) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = nblocks_x + inbr case default - call abort_ice(subname//' ERROR: unknown west boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -688,22 +600,14 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock + 1 if (inbr > nblocks_x) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = inbr - nblocks_x case default - call abort_ice(subname//' ERROR: unknown east boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr > nblocks_y) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = jnbr - nblocks_y case ('tripole':'tripoleT') @@ -717,7 +621,7 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & if (inbr <= 0) inbr = inbr + nblocks_x jnbr = -jBlock case default - call abort_ice(subname//' ERROR: unknown north boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif @@ -727,22 +631,14 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & jnbr = jBlock + 1 if (inbr < 1) then select case(iBoundary) - case ('open') - inbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - inbr = 0 case ('cyclic') inbr = nblocks_x + inbr case default - call abort_ice(subname//' ERROR: unknown west boundary') + inbr = 0 ! do not write into the neighbor's ghost cells end select endif if (jnbr > nblocks_y) then select case(jBoundary) - case ('open') - jnbr = 0 ! do not write into the neighbor's ghost cells - case ('closed') - jnbr = 0 case ('cyclic') jnbr = jnbr + nblocks_y case ('tripole':'tripoleT') @@ -756,7 +652,7 @@ function ice_blocksGetNbrID(blockID, direction, iBoundary, jBoundary) & if (inbr > nblocks_x) inbr = inbr - nblocks_x jnbr = -jBlock case default - call abort_ice(subname//' ERROR: unknown north boundary') + jnbr = 0 ! do not write into the neighbor's ghost cells end select endif diff --git a/cicecore/cicedyn/infrastructure/ice_domain.F90 b/cicecore/cicedyn/infrastructure/ice_domain.F90 index 9a0941e19..464c5ee30 100644 --- a/cicecore/cicedyn/infrastructure/ice_domain.F90 +++ b/cicecore/cicedyn/infrastructure/ice_domain.F90 @@ -224,6 +224,30 @@ subroutine init_domain_blocks call broadcast_scalar(nx_global, master_task) call broadcast_scalar(ny_global, master_task) +!---------------------------------------------------------------------- +! +! perform some basic checks on namelist +! +!---------------------------------------------------------------------- + + if (ew_boundary_type /= 'open' .and. & + ew_boundary_type /= 'closed' .and. & + ew_boundary_type /= 'cyclic' .and. & + ew_boundary_type /= 'zero_gradient' .and. & + ew_boundary_type /= 'linear_extrap') then + call abort_ice(subname//' ERROR: ew_boundary_type unsupported = '//trim(ew_boundary_type), file=__FILE__, line=__LINE__) + endif + + if (ns_boundary_type /= 'open' .and. & + ns_boundary_type /= 'closed' .and. & + ns_boundary_type /= 'cyclic' .and. & + ns_boundary_type /= 'tripole' .and. & + ns_boundary_type /= 'tripoleT' .and. & + ns_boundary_type /= 'zero_gradient' .and. & + ns_boundary_type /= 'linear_extrap') then + call abort_ice(subname//' ERROR: ns_boundary_type unsupported = '//trim(ns_boundary_type), file=__FILE__, line=__LINE__) + endif + !---------------------------------------------------------------------- ! ! Set nprocs if not explicitly set to valid value in namelist diff --git a/cicecore/cicedyn/infrastructure/ice_grid.F90 b/cicecore/cicedyn/infrastructure/ice_grid.F90 index 13a1aa098..f8bdcf4f0 100644 --- a/cicecore/cicedyn/infrastructure/ice_grid.F90 +++ b/cicecore/cicedyn/infrastructure/ice_grid.F90 @@ -421,7 +421,7 @@ subroutine init_grid1 ! Fill ULAT select case(trim(grid_format)) - case ('mom_nc') + case('mom_nc') if (my_task == master_task) then allocate(work_mom(nx_global*2+1, ny_global*2+1), stat=ierr) @@ -479,7 +479,7 @@ subroutine init_grid1 ! Fill kmt if (trim(kmt_type) =='file') then select case(trim(grid_format)) - case ('mom_nc', 'pop_nc', 'pop_nc_ext', 'geosnc') + case('mom_nc', 'pop_nc', 'pop_nc_ext', 'geosnc') ! mask variable name might be kmt or mask, check both call ice_open_nc(kmt_file,fid_kmt) @@ -610,11 +610,11 @@ subroutine init_grid2 select case (trim(grid_format)) case('mom_nc') call mom_grid ! derive cice grid from MOM supergrid nc file - case ('pop_nc') + case('pop_nc') call popgrid_nc ! read POP grid lengths from nc file - case ('pop_nc_ext') + case('pop_nc_ext') call popgrid_nc_ext ! read POP extended grid lengths from nc file - case ('geosnc') + case('geosnc') call geosgrid_nc ! read GEOS MOM grid used from nc file case default call popgrid ! read POP grid lengths directly @@ -1894,7 +1894,7 @@ subroutine mom_corners_global(work_mom, G_U, G_T, G_E, G_N) case('cyclic') G_T(nx_global+1,:) = G_T(1,:) G_N(nx_global+1,:) = G_N(1,:) - case('open') + case('open','zero_gradient','linear_extrap') do j=1, ny_global+1 G_T(nx_global+1,j) = 2 * G_T(nx_global, j) - G_T(nx_global-1, j) G_N(nx_global+1,j) = 2 * G_N(nx_global, j) - G_N(nx_global-1, j) @@ -1909,15 +1909,15 @@ subroutine mom_corners_global(work_mom, G_U, G_T, G_E, G_N) im1 = im1 + 2 enddo select case (trim(ns_boundary_type)) - case ('tripole') + case('tripole') do i = 1, nx_global+1 G_T(i,ny_global+1) = G_T(nx_global+1-i, ny_global) G_E(i,ny_global+1) = G_E(nx_global+1-i, ny_global) enddo - case ('cyclic') + case('cyclic') G_T(:,ny_global+1) = G_T(:,1) G_E(:,ny_global+1) = G_E(:,1) - case ('open') + case('open','zero_gradient','linear_extrap') do i = 1, nx_global+1 G_T(i,ny_global+1) = 2 * G_T(i, ny_global) - G_T(i, ny_global-1) G_E(i,ny_global+1) = 2 * G_E(i, ny_global) - G_E(i, ny_global-1) @@ -2074,19 +2074,20 @@ subroutine mom_dx(work_mom) jm1 = jm1 + 2 ; jm2 = jm2 + 2 enddo jm1 = 2 ; jm2 = 3 ! middle , top of first row - if (trim(ew_boundary_type) == 'cyclic') then - do j = 1, ny_global - G_dxE(nx_global,j) = work_mom(2*nx_global, jm1) + work_mom(1, jm1) !dxE - G_dxU(nx_global,j) = work_mom(2*nx_global, jm2) + work_mom(1, jm2) !dxU - jm1 = jm1 + 2 ; jm2 = jm2 + 2 - enddo - else if (trim(ew_boundary_type) == 'open') then - do j = 1, ny_global - G_dxE(nx_global,j) = 4*work_mom(2*nx_global, jm1) - 2*work_mom(2*nx_global-1, jm1) !dxE - G_dxU(nx_global,j) = 4*work_mom(2*nx_global, jm2) - 2*work_mom(2*nx_global-1, jm2) !dxU - jm1 = jm1 + 2 ; jm2 = jm2 + 2 - enddo - endif + select case (trim(ew_boundary_type)) + case('cyclic') + do j = 1, ny_global + G_dxE(nx_global,j) = work_mom(2*nx_global, jm1) + work_mom(1, jm1) !dxE + G_dxU(nx_global,j) = work_mom(2*nx_global, jm2) + work_mom(1, jm2) !dxU + jm1 = jm1 + 2 ; jm2 = jm2 + 2 + enddo + case('open','zero_gradient','linear_extrap') + do j = 1, ny_global + G_dxE(nx_global,j) = 4*work_mom(2*nx_global, jm1) - 2*work_mom(2*nx_global-1, jm1) !dxE + G_dxU(nx_global,j) = 4*work_mom(2*nx_global, jm2) - 2*work_mom(2*nx_global-1, jm2) !dxU + jm1 = jm1 + 2 ; jm2 = jm2 + 2 + enddo + end select endif call scatter_global(dxT, G_dxT, master_task, distrb_info, & @@ -2168,25 +2169,26 @@ subroutine mom_dy(work_mom) im1 = im1 + 2 ; im2 = im2 + 2 enddo im1 = 2 ; im2 = 3 - if (trim(ns_boundary_type) == 'tripole') then - do i = 1, nx_global - G_dyN(i,ny_global) = work_mom(im1, 2*ny_global) + work_mom(2*nx_global+2-im1, 2*ny_global) !dyN - G_dyU(i,ny_global) = work_mom(im2, 2*ny_global) + work_mom(2*nx_global+2-im2, 2*ny_global) !dyU - im1 = im1 + 2 ; im2 = im2 + 2 - enddo - else if (trim(ns_boundary_type) == 'cyclic') then - do i = 1, nx_global - G_dyN(i,ny_global) = work_mom(im1, 2*ny_global) + work_mom(im1, 1) !dyN - G_dyU(i,ny_global) = work_mom(im2, 2*ny_global) + work_mom(im2, 1) !dyU - im1 = im1 + 2 ; im2 = im2 + 2 - enddo - else if (trim(ns_boundary_type) == 'open') then - do i = 1, nx_global - G_dyN(i,ny_global) = 4*work_mom(im1, 2*ny_global) - 2*work_mom(im1, 2*ny_global-1) !dyN - G_dyU(i,ny_global) = 4*work_mom(im2, 2*ny_global) - 2*work_mom(im2, 2*ny_global-1) !dyU - im1 = im1 + 2 ; im2 = im2 + 2 - enddo - endif + select case (trim(ns_boundary_type)) + case('tripole') + do i = 1, nx_global + G_dyN(i,ny_global) = work_mom(im1, 2*ny_global) + work_mom(2*nx_global+2-im1, 2*ny_global) !dyN + G_dyU(i,ny_global) = work_mom(im2, 2*ny_global) + work_mom(2*nx_global+2-im2, 2*ny_global) !dyU + im1 = im1 + 2 ; im2 = im2 + 2 + enddo + case('cyclic') + do i = 1, nx_global + G_dyN(i,ny_global) = work_mom(im1, 2*ny_global) + work_mom(im1, 1) !dyN + G_dyU(i,ny_global) = work_mom(im2, 2*ny_global) + work_mom(im2, 1) !dyU + im1 = im1 + 2 ; im2 = im2 + 2 + enddo + case('open','zero_gradient','linear_extrap') + do i = 1, nx_global + G_dyN(i,ny_global) = 4*work_mom(im1, 2*ny_global) - 2*work_mom(im1, 2*ny_global-1) !dyN + G_dyU(i,ny_global) = 4*work_mom(im2, 2*ny_global) - 2*work_mom(im2, 2*ny_global-1) !dyU + im1 = im1 + 2 ; im2 = im2 + 2 + enddo + end select endif call scatter_global(dyT, G_dyT, master_task, distrb_info, & @@ -2291,13 +2293,14 @@ subroutine mom_area(work_mom) do j = 1, ny_global - 1 G_tarea(nx_global,j) = work_mom(im1, jm1) + work_mom(im1, jm2) & + work_mom(im2, jm1) + work_mom(im2, jm2) - if (trim(ew_boundary_type) == 'cyclic') then - G_uarea(nx_global,j) = work_mom(im2, jm2) + work_mom(im2, jm3) & - + work_mom(im3, jm2) + work_mom(im3, jm3) - else if (trim(ew_boundary_type) == 'open') then - G_uarea(nx_global,j) = 4*work_mom(im2, jm2) + 4*work_mom(im2, jm3) & - - 2*work_mom(im1, jm2) - 2*work_mom(im1, jm3) - endif + select case (trim(ew_boundary_type)) + case('cyclic') + G_uarea(nx_global,j) = work_mom(im2, jm2) + work_mom(im2, jm3) & + + work_mom(im3, jm2) + work_mom(im3, jm3) + case('open','zero_gradient','linear_extrap') + G_uarea(nx_global,j) = 4*work_mom(im2, jm2) + 4*work_mom(im2, jm3) & + - 2*work_mom(im1, jm2) - 2*work_mom(im1, jm3) + end select jm1 = jm1 + 2 ; jm2 = jm2 + 2 ; jm3 = jm3 + 2 enddo @@ -2307,16 +2310,17 @@ subroutine mom_area(work_mom) do i = 1, nx_global -1 G_tarea(i,ny_global) = work_mom(im1, jm1) + work_mom(im1, jm2) & + work_mom(im2, jm1) + work_mom(im2, jm2) - if (trim(ns_boundary_type) == 'tripole') then - G_uarea(i,ny_global) = work_mom(im2, jm2) + work_mom(2*nx_global+1-im2, jm2) & - + work_mom(im3, jm2) + work_mom(2*nx_global+1-im3, jm2) - else if (trim(ns_boundary_type) == 'cyclic') then - G_uarea(i,ny_global) = work_mom(im2, jm2) + work_mom(im2, jm3) & - + work_mom(im3, jm2) + work_mom(im3, jm3) - else if (trim(ns_boundary_type) == 'open') then - G_uarea(i,ny_global) = 4*work_mom(im2, jm2) + 4*work_mom(im3, jm2) & - - 2*work_mom(im2, jm1) - 2*work_mom(im3, jm1) - endif + select case (trim(ns_boundary_type)) + case('tripole') + G_uarea(i,ny_global) = work_mom(im2, jm2) + work_mom(2*nx_global+1-im2, jm2) & + + work_mom(im3, jm2) + work_mom(2*nx_global+1-im3, jm2) + case('cyclic') + G_uarea(i,ny_global) = work_mom(im2, jm2) + work_mom(im2, jm3) & + + work_mom(im3, jm2) + work_mom(im3, jm3) + case('open','zero_gradient','linear_extrap') + G_uarea(i,ny_global) = 4*work_mom(im2, jm2) + 4*work_mom(im3, jm2) & + - 2*work_mom(im2, jm1) - 2*work_mom(im3, jm1) + end select im1 = im1 + 2 ; im2 = im2 + 2 ; im3 = im3 + 2 enddo @@ -2327,20 +2331,28 @@ subroutine mom_area(work_mom) + work_mom(im2, jm1) + work_mom(im2, jm2) if (trim(ns_boundary_type) == 'tripole') then G_uarea(nx_global,ny_global) = 2*(work_mom(im2, jm2) + work_mom(1, jm2)) - else if (trim(ns_boundary_type) == 'cyclic' & - .and. trim(ew_boundary_type) == 'cyclic') then + else if ((trim(ns_boundary_type) == 'cyclic') .and. & + (trim(ew_boundary_type) == 'cyclic')) then G_uarea(nx_global,ny_global) = work_mom(im2, jm2) + work_mom(1, jm2) & + work_mom(im2, 1) + work_mom(1, 1) - else if (trim(ns_boundary_type) == 'cyclic' & - .and. trim(ew_boundary_type) == 'open') then + else if ((trim(ns_boundary_type) == 'cyclic') .and. & + (trim(ew_boundary_type) == 'open' .or. & + trim(ew_boundary_type) == 'zero_gradient' .or. & + trim(ew_boundary_type) == 'linear_extrap')) then G_uarea(nx_global,ny_global) = 4*work_mom(im2, jm2) + 4*work_mom(im2, 1) & - 2*work_mom(im1, jm2) - 2*work_mom(im1, 1) - else if (trim(ns_boundary_type) == 'open' & - .and. trim(ew_boundary_type) == 'cyclic') then + else if ((trim(ns_boundary_type) == 'open' .or. & + trim(ns_boundary_type) == 'zero_gradient' .or. & + trim(ns_boundary_type) == 'linear_extrap') .and. & + (trim(ew_boundary_type) == 'cyclic')) then G_uarea(nx_global,ny_global) = 4*work_mom(im2, jm2) + 4*work_mom(1, jm2) & - 2*work_mom(im2, jm1) - 2*work_mom(1, jm1) - else if (trim(ns_boundary_type) == 'open' & - .and. trim(ew_boundary_type) == 'open') then + else if ((trim(ns_boundary_type) == 'open' .or. & + trim(ns_boundary_type) == 'zero_gradient' .or. & + trim(ns_boundary_type) == 'linear_extrap') .and. & + (trim(ew_boundary_type) == 'open' .or. & + trim(ew_boundary_type) == 'zero_gradient' .or. & + trim(ew_boundary_type) == 'linear_extrap')) then G_uarea(nx_global,ny_global) = 8*work_mom(im2, jm2) & - 2*work_mom(im2, jm1) - 2*work_mom(im1, jm2) endif @@ -3281,29 +3293,31 @@ subroutine global_ext_halo(array) character(len=*), parameter :: subname = '(global_ext_halo)' do n = 1,nghost - if (ns_boundary_type =='cyclic') then - array(:,n) = array(:,ny_global+n) - array(:,ny_global+nghost+n) = array(:,nghost+n) - elseif (ns_boundary_type == 'open') then - array(:,n) = array(:,nghost+1) - array(:,ny_global+nghost+n) = array(:,ny_global+nghost) - else - array(:,n) = c0 - array(:,ny_global+nghost+n) = c0 - endif + select case (ns_boundary_type) + case('cyclic') + array(:,n) = array(:,ny_global+n) + array(:,ny_global+nghost+n) = array(:,nghost+n) + case('open','zero_gradient','linear_extrap') + array(:,n) = array(:,nghost+1) + array(:,ny_global+nghost+n) = array(:,ny_global+nghost) + case default + array(:,n) = c0 + array(:,ny_global+nghost+n) = c0 + end select enddo do n = 1,nghost - if (ew_boundary_type =='cyclic') then - array(n ,:) = array(nx_global+n,:) - array(nx_global+nghost+n,:) = array(nghost+n ,:) - elseif (ew_boundary_type == 'open') then - array(n ,:) = array(nghost+1 ,:) - array(nx_global+nghost+n,:) = array(nx_global+nghost,:) - else - array(n ,:) = c0 - array(nx_global+nghost+n,:) = c0 - endif + select case (ew_boundary_type) + case('cyclic') + array(n ,:) = array(nx_global+n,:) + array(nx_global+nghost+n,:) = array(nghost+n ,:) + case('open','zero_gradient','linear_extrap') + array(n ,:) = array(nghost+1 ,:) + array(nx_global+nghost+n,:) = array(nx_global+nghost,:) + case default + array(n ,:) = c0 + array(nx_global+nghost+n,:) = c0 + end select enddo end subroutine global_ext_halo @@ -3327,7 +3341,7 @@ subroutine makemask puny real (kind=dbl_kind), dimension(:,:,:), allocatable :: & - uvmCD + uvmCD type (block) :: & this_block ! block information for current block @@ -3353,6 +3367,7 @@ subroutine makemask bm = c0 allocate(uvmCD(nx_block,ny_block,max_blocks), stat=ierr) if (ierr/=0) call abort_ice(subname//' ERROR: Out of memory', file=__FILE__, line=__LINE__) + uvmCD = c0 !$OMP PARALLEL DO PRIVATE(iblk,i,j,ilo,ihi,jlo,jhi,this_block) do iblk = 1, nblocks diff --git a/cicecore/drivers/unittest/halochk/halochk.F90 b/cicecore/drivers/unittest/halochk/halochk.F90 index 6e7ff4173..53ca598a7 100644 --- a/cicecore/drivers/unittest/halochk/halochk.F90 +++ b/cicecore/drivers/unittest/halochk/halochk.F90 @@ -5,7 +5,7 @@ module halochk_data use ice_kinds_mod, only: int_kind, dbl_kind, real_kind, log_kind use ice_blocks, only: block, get_block, nx_block, ny_block, nblocks_tot, nghost use ice_boundary, only: ice_HaloUpdate, ice_HaloUpdate_stress - use ice_constants, only: c0, c1, p5, & + use ice_constants, only: c0, c1, c2, p5, & field_loc_unknown, field_loc_noupdate, & field_loc_center, field_loc_NEcorner, & field_loc_Nface, field_loc_Eface, & @@ -69,10 +69,10 @@ program halochk integer(int_kind), parameter :: nz1 = 3 integer(int_kind), parameter :: nz2 = 4 real(dbl_kind) :: aichk,ajchk,cichk,cjchk,rival,rjval,rsign - real(dbl_kind) :: fillexpected + real(dbl_kind) :: fillexpected,cichk1,cichk2,cjchk1,cjchk2,wgt1,wgt2 character(len=16) :: locs_name(maxlocs), types_name(maxtypes), fill_name(maxfills) integer(int_kind) :: field_loc(maxlocs), field_type(maxtypes) - logical :: halofill + logical :: halofill, found integer(int_kind) :: npes, ierr, ntask, testcnt, tottest, tpcnt, tfcnt integer(int_kind) :: errorflag0, gflag, k1m, k2m, ptcntsum, failcntsum integer(int_kind), allocatable :: errorflag(:) @@ -461,8 +461,8 @@ program halochk larrayj1 = (mod(nint(darrayj1),2) == 1) endwhere if (halofill) then - call ice_haloUpdate(larrayi1, halo_info, field_loc(nl), field_type(nt), fillvalue=0) - call ice_haloUpdate(larrayj1, halo_info, field_loc(nl), field_type(nt), fillvalue=1) + call ice_haloUpdate(larrayi1, halo_info, field_loc(nl), field_type(nt), fillvalue=.false.) + call ice_haloUpdate(larrayj1, halo_info, field_loc(nl), field_type(nt), fillvalue=.true.) else call ice_haloUpdate(larrayi1, halo_info, field_loc(nl), field_type(nt)) call ice_haloUpdate(larrayj1, halo_info, field_loc(nl), field_type(nt)) @@ -486,7 +486,7 @@ program halochk endif endif - write(teststring(testcnt),'(6a8)') trim(halofld),trim(locs_name(nl)),trim(types_name(nt)),trim(fill_name(nf)), & + write(teststring(testcnt),'(4a8,2a12)') trim(halofld),trim(locs_name(nl)),trim(types_name(nt)),trim(fill_name(nf)), & trim(ew_boundary_type),trim(ns_boundary_type) do iblock = 1,numBlocks @@ -538,7 +538,8 @@ program halochk endif else - ! if ew_boundary_type is not cyclic we expect just fill values on outer boundary + + ! if boundary_type is not cyclic set outer boundary to fill, other special cases below if (ew_boundary_type /= 'cyclic' .and. & ((this_block%i_glob(ib) == 1 .and. i < ib) .or. & ! west outer face (this_block%i_glob(ie) == nx_global .and. i > ie))) then ! east outer face @@ -546,14 +547,13 @@ program halochk cjchk = fillexpected endif - ! if ns_boundary_type is not cyclic we expect just fill values on outer boundary except + ! if boundary_type is not cyclic set outer boundary to fill, other special cases below ! - tripole north edge will be haloed and is updated below, default to fill value for now ! - tripole south edge will be set to the fillvalue or to haloupdate internal default (c0) ! tripole basically assumes south edge is land or always ice free in CICE if (ns_boundary_type /= 'cyclic' .and. & ((this_block%j_glob(jb) == 1 .and. j < jb) .or. & ! south outer face (this_block%j_glob(je) == ny_global .and. j > je))) then ! north outer face - ! ns_boundary_type is not cyclic and on outer boundary if ((ns_boundary_type == 'tripole' .or. & ns_boundary_type == 'tripoleT') .and. & .not. halofill) then @@ -565,6 +565,119 @@ program halochk endif endif + ! zero_gradient and linear_extrap edges then corners + if (ew_boundary_type == 'zero_gradient' .or. ew_boundary_type == 'linear_extrap') then + wgt1 = c1 ! zero_gradient + wgt2 = c0 + if (this_block%i_glob(ib) == 1 .and. i < ib) then ! West + if (ew_boundary_type == 'linear_extrap') then + wgt1 = real(ib-i+1,dbl_kind) + wgt2 = real(ib-i ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cidata_bas(ib,j,k1,k2,iblock) - wgt2*cidata_bas(ib+1,j,k1,k2,iblock) + cjchk = wgt1*cjdata_bas(ib,j,k1,k2,iblock) - wgt2*cjdata_bas(ib+1,j,k1,k2,iblock) + elseif (this_block%i_glob(ie) == nx_global .and. i > ie) then ! East + if (ew_boundary_type == 'linear_extrap') then + wgt1 = real(i-ie+1,dbl_kind) + wgt2 = real(i-ie ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cidata_bas(ie,j,k1,k2,iblock) - wgt2*cidata_bas(ie-1,j,k1,k2,iblock) + cjchk = wgt1*cjdata_bas(ie,j,k1,k2,iblock) - wgt2*cjdata_bas(ie-1,j,k1,k2,iblock) + endif + endif + + if (ns_boundary_type == 'zero_gradient' .or. ns_boundary_type == 'linear_extrap') then + wgt1 = c1 ! zero_gradient + wgt2 = c0 + if (this_block%j_glob(jb) == 1 .and. j < jb) then ! South + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(jb-j+1,dbl_kind) + wgt2 = real(jb-j ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cidata_bas(i,jb,k1,k2,iblock) - wgt2*cidata_bas(i,jb+1,k1,k2,iblock) + cjchk = wgt1*cjdata_bas(i,jb,k1,k2,iblock) - wgt2*cjdata_bas(i,jb+1,k1,k2,iblock) + elseif (this_block%j_glob(je) == ny_global .and. j > je) then ! North + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(j-je+1,dbl_kind) + wgt2 = real(j-je ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cidata_bas(i,je,k1,k2,iblock) - wgt2*cidata_bas(i,je-1,k1,k2,iblock) + cjchk = wgt1*cjdata_bas(i,je,k1,k2,iblock) - wgt2*cjdata_bas(i,je-1,k1,k2,iblock) + endif + + ! Boundary Corners, can come at it either direction, do ns then ew + if (ew_boundary_type == 'zero_gradient' .or. ew_boundary_type == 'linear_extrap') then + wgt1 = c1 ! zero_gradient + wgt2 = c0 + found = .false. + if (this_block%i_glob(ib) == 1 .and. i < ib) then + if (this_block%j_glob(jb) == 1 .and. j < jb) then + found = .true. ! Southwest + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(jb-j+1,dbl_kind) + wgt2 = real(jb-j ,dbl_kind) ! wgt1 - 1 + endif + cichk1 = wgt1*cidata_bas(ib ,jb,k1,k2,iblock) - wgt2*cidata_bas(ib ,jb+1,k1,k2,iblock) + cichk2 = wgt1*cidata_bas(ib+1,jb,k1,k2,iblock) - wgt2*cidata_bas(ib+1,jb+1,k1,k2,iblock) + cjchk1 = wgt1*cjdata_bas(ib ,jb,k1,k2,iblock) - wgt2*cjdata_bas(ib ,jb+1,k1,k2,iblock) + cjchk2 = wgt1*cjdata_bas(ib+1,jb,k1,k2,iblock) - wgt2*cjdata_bas(ib+1,jb+1,k1,k2,iblock) + elseif (this_block%j_glob(je) == ny_global .and. j > je) then + found = .true. ! Northwest + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(j-je+1,dbl_kind) + wgt2 = real(j-je ,dbl_kind) ! wgt1 - 1 + endif + cichk1 = wgt1*cidata_bas(ib ,je,k1,k2,iblock) - wgt2*cidata_bas(ib ,je-1,k1,k2,iblock) + cichk2 = wgt1*cidata_bas(ib+1,je,k1,k2,iblock) - wgt2*cidata_bas(ib+1,je-1,k1,k2,iblock) + cjchk1 = wgt1*cjdata_bas(ib ,je,k1,k2,iblock) - wgt2*cjdata_bas(ib ,je-1,k1,k2,iblock) + cjchk2 = wgt1*cjdata_bas(ib+1,je,k1,k2,iblock) - wgt2*cjdata_bas(ib+1,je-1,k1,k2,iblock) + endif + if (found) then + wgt1 = c1 ! zero_gradient + wgt2 = c0 + if (ew_boundary_type == 'linear_extrap') then + wgt1 = real(ib-i+1,dbl_kind) + wgt2 = real(ib-i ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cichk1 - wgt2*cichk2 + cjchk = wgt1*cjchk1 - wgt2*cjchk2 + endif + elseif (this_block%i_glob(ie) == nx_global .and. i > ie) then + if (this_block%j_glob(jb) == 1 .and. j < jb) then + found = .true. ! Southeast + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(jb-j+1,dbl_kind) + wgt2 = real(jb-j ,dbl_kind) ! wgt1 - 1 + endif + cichk1 = wgt1*cidata_bas(ie ,jb,k1,k2,iblock) - wgt2*cidata_bas(ie ,jb+1,k1,k2,iblock) + cichk2 = wgt1*cidata_bas(ie-1,jb,k1,k2,iblock) - wgt2*cidata_bas(ie-1,jb+1,k1,k2,iblock) + cjchk1 = wgt1*cjdata_bas(ie ,jb,k1,k2,iblock) - wgt2*cjdata_bas(ie ,jb+1,k1,k2,iblock) + cjchk2 = wgt1*cjdata_bas(ie-1,jb,k1,k2,iblock) - wgt2*cjdata_bas(ie-1,jb+1,k1,k2,iblock) + elseif (this_block%j_glob(je) == ny_global .and. j > je) then + found = .true. ! Northeast + if (ns_boundary_type == 'linear_extrap') then + wgt1 = real(j-je+1,dbl_kind) + wgt2 = real(j-je ,dbl_kind) ! wgt1 - 1 + endif + cichk1 = wgt1*cidata_bas(ie ,je,k1,k2,iblock) - wgt2*cidata_bas(ie ,je-1,k1,k2,iblock) + cichk2 = wgt1*cidata_bas(ie-1,je,k1,k2,iblock) - wgt2*cidata_bas(ie-1,je-1,k1,k2,iblock) + cjchk1 = wgt1*cjdata_bas(ie ,je,k1,k2,iblock) - wgt2*cjdata_bas(ie ,je-1,k1,k2,iblock) + cjchk2 = wgt1*cjdata_bas(ie-1,je,k1,k2,iblock) - wgt2*cjdata_bas(ie-1,je-1,k1,k2,iblock) + endif + if (found) then + wgt1 = c1 ! zero_gradient + wgt2 = c0 + if (ew_boundary_type == 'linear_extrap') then + wgt1 = real(i-ie+1,dbl_kind) + wgt2 = real(i-ie ,dbl_kind) ! wgt1 - 1 + endif + cichk = wgt1*cichk1 - wgt2*cichk2 + cjchk = wgt1*cjchk1 - wgt2*cjchk2 + endif + endif + endif + endif ! zero_gradient, linear_extrap + if (index(halofld,'STRESS') > 0) then ! only updates on tripole zipper for tripole grids ! darrayi10 is copy of darrayi1 before halo call @@ -765,10 +878,10 @@ program halochk do n = 1,tottest if (errorflag(n) == passflag) then tpcnt = tpcnt + 1 - write(6,'(2a,2i8)') 'PASS ',trim(teststring(n)),ptcnt(n),failcnt(n) + write(6,'(2a,2i9)') 'PASS ',trim(teststring(n)),ptcnt(n),failcnt(n) else tfcnt = tfcnt + 1 - write(6,'(2a,2i8)') 'FAIL ',trim(teststring(n)),ptcnt(n),failcnt(n) + write(6,'(2a,2i9)') 'FAIL ',trim(teststring(n)),ptcnt(n),failcnt(n) endif enddo write(6,*) ' ' diff --git a/configuration/scripts/options/set_nml.bcclosed b/configuration/scripts/options/set_nml.bcclosed new file mode 100644 index 000000000..b936253c6 --- /dev/null +++ b/configuration/scripts/options/set_nml.bcclosed @@ -0,0 +1,3 @@ +ew_boundary_type = 'closed' +ns_boundary_type = 'closed' + diff --git a/configuration/scripts/options/set_nml.cyclic b/configuration/scripts/options/set_nml.bccyclic similarity index 100% rename from configuration/scripts/options/set_nml.cyclic rename to configuration/scripts/options/set_nml.bccyclic diff --git a/configuration/scripts/options/set_nml.bccyclicextrap b/configuration/scripts/options/set_nml.bccyclicextrap new file mode 100644 index 000000000..8ad7fc825 --- /dev/null +++ b/configuration/scripts/options/set_nml.bccyclicextrap @@ -0,0 +1,4 @@ +ew_boundary_type = 'cyclic' +ns_boundary_type = 'linear_extrap' +restart_ext = .true. + diff --git a/configuration/scripts/options/set_nml.bclinearextrap b/configuration/scripts/options/set_nml.bclinearextrap new file mode 100644 index 000000000..63a4d5b61 --- /dev/null +++ b/configuration/scripts/options/set_nml.bclinearextrap @@ -0,0 +1,3 @@ +ew_boundary_type = 'linear_extrap' +ns_boundary_type = 'linear_extrap' +restart_ext = .true. diff --git a/configuration/scripts/options/set_nml.open b/configuration/scripts/options/set_nml.bcopen similarity index 100% rename from configuration/scripts/options/set_nml.open rename to configuration/scripts/options/set_nml.bcopen diff --git a/configuration/scripts/options/set_nml.tripole b/configuration/scripts/options/set_nml.bctripole similarity index 100% rename from configuration/scripts/options/set_nml.tripole rename to configuration/scripts/options/set_nml.bctripole diff --git a/configuration/scripts/options/set_nml.tripolet b/configuration/scripts/options/set_nml.bctripolet similarity index 100% rename from configuration/scripts/options/set_nml.tripolet rename to configuration/scripts/options/set_nml.bctripolet diff --git a/configuration/scripts/options/set_nml.bczerogradient b/configuration/scripts/options/set_nml.bczerogradient new file mode 100644 index 000000000..eed3e21d5 --- /dev/null +++ b/configuration/scripts/options/set_nml.bczerogradient @@ -0,0 +1,3 @@ +ew_boundary_type = 'zero_gradient' +ns_boundary_type = 'zero_gradient' +restart_ext = .true. diff --git a/configuration/scripts/options/set_nml.boxgauss b/configuration/scripts/options/set_nml.boxgauss new file mode 100644 index 000000000..b48fd3951 --- /dev/null +++ b/configuration/scripts/options/set_nml.boxgauss @@ -0,0 +1,19 @@ +days_per_year = 360 +use_leap_years = .false. +dxrect = 16.e5 +dyrect = 16.e5 +kmt_type = 'none' +ice_data_conc = 'p5' +ice_data_dist = 'gauss' +calc_strair = .false. +atm_data_type = 'uniform_northeast' +ocn_data_type = 'calm' +ice_data_type = 'uniform' +histfreq = 'm','d','x','x','x' +hist_avg = .true.,.false.,.false.,.false.,.false. +f_aice = 'md' +f_hi = 'md' +f_hs = 'md' +f_Tsfc = 'md' +f_uvel = 'md' +f_vvel = 'md' diff --git a/configuration/scripts/options/set_nml.boxopen b/configuration/scripts/options/set_nml.boxopen index 081865d7a..7605f5141 100644 --- a/configuration/scripts/options/set_nml.boxopen +++ b/configuration/scripts/options/set_nml.boxopen @@ -6,8 +6,6 @@ histfreq = 'd','x','x','x','x' grid_type = 'rectangular' dxrect = 16.e5 dyrect = 16.e5 -ew_boundary_type = 'cyclic' -ns_boundary_type = 'open' ktherm = -1 kstrength = 0 kdyn = 1 diff --git a/configuration/scripts/tests/base_suite.ts b/configuration/scripts/tests/base_suite.ts index 4af813211..f4f4ebf95 100644 --- a/configuration/scripts/tests/base_suite.ts +++ b/configuration/scripts/tests/base_suite.ts @@ -49,6 +49,8 @@ restart gbox128 4x4 boxrestore,medium smoke gbox128 4x4 boxrestore,short,debug restart gbox80 1x1 box2001 smoke gbox80 1x1 boxslotcyl +smoke gbox80 8x2 boxgauss,bclinearextrap,debug +smoke gbox80 9x2 boxgauss,bczerogradient,debug smoke gbox12 1x1x12x12x1 boxchan,diag1,debug restart gx3 8x2 modal smoke gx3 8x2 bgcz,diag1,run5day diff --git a/configuration/scripts/tests/decomp_suite.ts b/configuration/scripts/tests/decomp_suite.ts index d33572f0b..4b9e10602 100644 --- a/configuration/scripts/tests/decomp_suite.ts +++ b/configuration/scripts/tests/decomp_suite.ts @@ -3,6 +3,11 @@ restart gx3 4x2x25x29x4 dslenderX2 restart gx1 64x1x16x16x10 dwghtfile restart gx1 32x2x10x12x32 dsectcart,short restart gbox180 16x1x6x6x60 dspacecurve,debugblocks +restart gbox80 4x2x23x21x6 boxgauss,bczerogradient +restart gbox80 2x2x29x29 boxgauss,bclinearextrap +restart gbox80 3x2x22x21 boxgauss,bccyclicextrap +restart gbox80 6x2x13x12 boxgauss,bcclosed +restart gbox80 8x2x6x7 boxgauss,bccyclic decomp gx3 4x2x25x29x5 none decomp gx3 4x2x25x29 none decomp gx3 4x2x25x29x5 dynpicard,reprosum @@ -26,11 +31,19 @@ restart gx3 16x2x3x3x100 droundrobin restart_gx3_4x2x25x2 restart gx3 16x2x8x8x80 dspiralcenter restart_gx3_4x2x25x29x4_dslenderX2 restart gx3 10x1x10x29x4 dsquarepop,thread restart_gx3_4x2x25x29x4_dslenderX2 restart gx3 8x1x25x29 drakeX2,thread restart_gx3_4x2x25x29x4_dslenderX2 +restart gbox80 1x2x23x21x20 boxgauss,bczerogradient restart_gbox80_4x2x23x21x6_bczerogradient_boxgauss +restart gbox80 1x1x15x17 boxgauss,bclinearextrap,thread restart_gbox80_2x2x29x29_bclinearextrap_boxgauss +restart gbox80 1x2x29x28 boxgauss,bccyclicextrap restart_gbox80_3x2x22x21_bccyclicextrap_boxgauss +restart gbox80 1x4x12x13 boxgauss,bcclosed restart_gbox80_6x2x13x12_bcclosed_boxgauss +restart gbox80 1x8x9x8 boxgauss,bccyclic restart_gbox80_8x2x6x7_bccyclic_boxgauss smoke gx3 4x2x25x29 debug,run2day,dslenderX2 smoke gx1 64x1x16x16 debug,run2day,dwghtfile smoke gx1 32x2x10x12 debug,run2day,dsectcart smoke gbox180 16x1x6x6 debug,run2day,dspacecurve,debugblocks +smoke gbox80 4x2x23x21x6 debug,run2day,boxgauss,bczerogradient +smoke gbox80 3x2x22x21 debug,run2day,boxgauss,bccyclicextrap +smoke gbox80 2x2x29x29 debug,run2day,boxgauss,bclinearextrap smoke gx3 1x1x25x58 debug,run2day,droundrobin,thread smoke_gx3_4x2x25x29_debug_dslenderX2_run2day smoke gx3 20x1x5x116 debug,run2day,dslenderX1,thread smoke_gx3_4x2x25x29_debug_dslenderX2_run2day smoke gx3 6x2x4x29 debug,run2day,dspacecurve smoke_gx3_4x2x25x29_debug_dslenderX2_run2day diff --git a/configuration/scripts/tests/gridsys_suite.ts b/configuration/scripts/tests/gridsys_suite.ts index eca6497a4..5a46a6d74 100644 --- a/configuration/scripts/tests/gridsys_suite.ts +++ b/configuration/scripts/tests/gridsys_suite.ts @@ -21,6 +21,8 @@ smoke gbox80 2x4 boxnodyn smoke gbox80 4x2 boxclosed,boxforcee,run1day smoke gbox80 4x1 boxclosed,boxforcene,run1day,kmtislands smoke gbox80 4x2 boxopen,kmtislands,boxforcee,run1day +smoke gbox80 6x2 boxopen,kmtislands,boxforcee,run1day,bczerogradient +smoke gbox80 8x1 boxopen,kmtislands,boxforcee,run1day,bclinearextrap smoke gbox80 2x2 boxclosed,boxforcen,run1day,vargrid smoke gx3 1x1x25x29 reprosum,run10day,dwblockall smoke_gx3_1x1x100x116_reprosum_run10day smoke gx3 1x1x5x4 reprosum,run10day,dwblockall smoke_gx3_1x1x100x116_reprosum_run10day @@ -44,6 +46,8 @@ smoke gbox80 2x4 boxnodyn,gridcd smoke gbox80 4x2 boxclosed,boxforcee,run1day,gridcd smoke gbox80 4x1 boxclosed,boxforcene,run1day,kmtislands,gridcd smoke gbox80 4x2 boxopen,kmtislands,boxforcee,run1day,gridcd +smoke gbox80 6x2 boxopen,kmtislands,boxforcee,run1day,bczerogradient,gridcd +smoke gbox80 8x1 boxopen,kmtislands,boxforcee,run1day,bclinearextrap,gridcd smoke gbox80 2x2 boxclosed,boxforcen,run1day,vargrid,gridcd smoke gx3 1x1x25x29 reprosum,run10day,dwblockall,gridcd smoke_gx3_1x1x100x116_gridcd_reprosum_run10day smoke gx3 1x1x5x4 reprosum,run10day,dwblockall,gridcd smoke_gx3_1x1x100x116_gridcd_reprosum_run10day @@ -67,6 +71,8 @@ smoke gbox80 2x4 boxnodyn,gridc smoke gbox80 4x2 boxclosed,boxforcee,run1day,gridc smoke gbox80 4x1 boxclosed,boxforcene,run1day,kmtislands,gridc smoke gbox80 4x2 boxopen,kmtislands,boxforcee,run1day,gridc +smoke gbox80 6x2 boxopen,kmtislands,boxforcee,run1day,bczerogradient,gridc +smoke gbox80 8x1 boxopen,kmtislands,boxforcee,run1day,bclinearextrap,gridc smoke gbox80 2x2 boxclosed,boxforcen,run1day,vargrid,gridc smoke gx3 1x1x25x29 reprosum,run10day,dwblockall,gridc smoke_gx3_1x1x100x116_gridc_reprosum_run10day smoke gx3 1x1x5x4 reprosum,run10day,dwblockall,gridc smoke_gx3_1x1x100x116_gridc_reprosum_run10day diff --git a/configuration/scripts/tests/unittest_suite.ts b/configuration/scripts/tests/unittest_suite.ts index 779e218ff..8aa4790bc 100644 --- a/configuration/scripts/tests/unittest_suite.ts +++ b/configuration/scripts/tests/unittest_suite.ts @@ -6,7 +6,7 @@ unittest gx3 1x1 calchk,short unittest gx3 4x1x25x29x4 sumchk unittest gx3 1x1x25x29x16 sumchk unittest tx1 8x1 sumchk -unittest tx1 8x1 sumchk,tripolet +unittest tx1 8x1 sumchk,bctripolet unittest gx3 4x1 bcstchk unittest gx3 1x1 bcstchk unittest gx3 8x2 gridavgchk,dwblockall @@ -14,33 +14,39 @@ unittest gx3 12x1 gridavgchk unittest gx1 28x1 gridavgchk,dwblockall unittest gx1 16x2 gridavgchk unittest gbox128 8x2 gridavgchk -unittest gbox80 1x1x10x10x80 halochk,cyclic,debug -unittest gbox80 1x1x10x10 halochk,cyclic,debug -unittest gbox80 1x1x24x23x16 halochk -unittest gbox80 1x1x24x23 halochk -unittest gbox80 1x1x23x24x16 halochk,cyclic -unittest gbox80 1x1x23x24 halochk,cyclic -unittest gbox80 1x1x23x23x16 halochk,open -unittest gbox80 1x1x23x23 halochk,open -unittest tx1 1x1x90x60x16 halochk,dwblockall +unittest gbox80 4x2x10x20x13 halochk,bccyclic,debug +unittest gbox80 1x1x20x10 halochk,bccyclic +unittest gbox80 1x1x24x23x18 halochk,debug +unittest gbox80 2x2x24x23 halochk +unittest gbox80 1x1x23x24x16 halochk,bccyclic,debug +unittest gbox80 3x2x23x24 halochk,bccyclic +unittest gbox80 6x1x23x25 halochk,bcopen,debug +unittest gbox80 1x1x25x23x20 halochk,bcopen +unittest gbox80 1x1x22x25 halochk,bczerogradient,debug +unittest gbox80 6x1x25x22x4 halochk,bczerogradient +unittest gbox80 5x2x25x22x5 halochk,bclinearextrap,debug +unittest gbox80 1x1x22x25 halochk,bclinearextrap +unittest gbox80 1x1x22x21x16 halochk,bccyclicextrap,debug +unittest gbox80 4x2x22x21 halochk,bccyclicextrap +unittest tx1 4x2x90x60x6 halochk,dwblockall unittest tx1 1x1x90x60 halochk,dwblockall -unittest tx1 1x1x90x60x16 halochk,dwblockall,tripolet -unittest tx1 1x1x90x60 halochk,dwblockall,tripolet +unittest tx1 1x1x90x60x20 halochk,dwblockall,bctripolet +unittest tx1 16x1x90x60 halochk,dwblockall,bctripolet unittest tx1 1x1x95x65x16 halochk,dwblockall -unittest tx1 1x1x95x65 halochk,dwblockall -unittest tx1 1x1x95x65x16 halochk,dwblockall,tripolet -unittest tx1 1x1x95x65 halochk,dwblockall,tripolet +unittest tx1 20x1x37x31 halochk,dwblockall +unittest tx1 12x2x45x35x12 halochk,dwblockall,bctripolet +unittest tx1 1x1x95x65 halochk,dwblockall,bctripolet unittest gx3 4x2 halochk,dwblockall,debug -unittest gx3 8x2x16x12x10 halochk,cyclic,dwblockall -unittest gx3 8x2x16x12 halochk,cyclic,dwblockall -unittest gx3 17x1x16x12x10 halochk,open,dwblockall -unittest gx3 17x1x16x12 halochk,open,dwblockall +unittest gx3 8x2x16x12x10 halochk,bccyclic,dwblockall +unittest gx3 8x2x16x12 halochk,bccyclic,dwblockall +unittest gx3 17x1x16x12x10 halochk,bcopen,dwblockall +unittest gx3 17x1x16x12 halochk,bcopen,dwblockall unittest tx1 4x2 halochk,dwblockall -unittest tx1 4x2 halochk,dwblockall,tripolet +unittest tx1 4x2 halochk,dwblockall,bctripolet unittest tx1 4x2x65x45x10 halochk,dwblockall unittest tx1 4x2x65x45 halochk,dwblockall -unittest tx1 4x2x57x43x12 halochk,dwblockall,tripolet -unittest tx1 4x2x57x43 halochk,dwblockall,tripolet +unittest tx1 4x2x57x43x12 halochk,dwblockall,bctripolet +unittest tx1 4x2x57x43 halochk,dwblockall,bctripolet unittest gx3 1x1 optargs unittest gx3 1x1 opticep unittest gx3 4x2x25x29x4 debug,run2day,dslenderX2,opticep,cmplog smoke_gx3_4x2x25x29x4_debug_dslenderX2_run2day diff --git a/doc/source/user_guide/ug_case_settings.rst b/doc/source/user_guide/ug_case_settings.rst index ea959868d..6c021a4d1 100644 --- a/doc/source/user_guide/ug_case_settings.rst +++ b/doc/source/user_guide/ug_case_settings.rst @@ -381,7 +381,9 @@ domain_nml "``distribution_wght_file``", "string", "distribution weight file when distribution_type is ``wghtfile``", "'unknown'" "``ew_boundary_type``", "``closed``", "force two gridcell wide land mask on x-direction boundaries for rectangular grids", "``cyclic``" "", "``cyclic``", "periodic boundary conditions in x-direction", "" - "", "``open``", "Dirichlet boundary conditions in x", "" + "", "``linear_extrap``", "constant gradient Neumann boundary condition in x based on near interior values", "" + "", "``open``", "no boundary condition applied in x, potential use with restoring", "" + "", "``zero_gradient``", "zero gradient Neumann boundary conditions in x based on near interior values", "" "``maskhalo_dyn``", "logical", "mask unused halo cells for dynamics", "``.false.``" "``maskhalo_remap``", "logical", "mask unused halo cells for transport", "``.false.``" "``maskhalo_bound``", "logical", "mask unused halo cells for boundary updates", "``.false.``" @@ -391,9 +393,11 @@ domain_nml "", "``-1``", "find number of MPI tasks automatically", "" "``ns_boundary_type``", "``closed``", "force two gridcell wide land mask on y-direction boundaries for rectangular grids", "``cyclic``" "", "``cyclic``", "periodic boundary conditions in y-direction", "" - "", "``open``", "Dirichlet boundary conditions in y", "" - "", "``tripole``", "U-fold tripole boundary conditions in y", "" - "", "``tripoleT``", "T-fold tripole boundary conditions in y", "" + "", "``linear_extrap``", "constant gradient Neumann boundary condition in y based on near interior values", "" + "", "``open``", "no boundary condition applied in y, potential use with restoring", "" + "", "``tripole``", "U-fold tripole boundary conditions in y at north boundary, closed boundary condition at south boundary", "" + "", "``tripoleT``", "T-fold tripole boundary conditions in y at north boundary, closed boundary condition at south boundary", "" + "", "``zero_gradient``", "zero gradient Neumann boundary conditions in y based on near interior values", "" "``nx_global``", "integer", "global grid size in x direction", "-1" "``ny_global``", "integer", "global grid size in y direction", "-1" "``processor_shape``", "``slenderX1``", "1 processor in the y direction used with ``distribution_type=cartesian``", "``slenderX2``" diff --git a/doc/source/user_guide/ug_implementation.rst b/doc/source/user_guide/ug_implementation.rst index 15c0decd1..f0ba6f408 100644 --- a/doc/source/user_guide/ug_implementation.rst +++ b/doc/source/user_guide/ug_implementation.rst @@ -424,17 +424,28 @@ category as a fourth dimension. Boundary Conditions ******************* -Much of the infrastructure used in CICE, including the boundary -routines, is adopted from POP. The boundary routines perform boundary -communications among processors when MPI is in use and among blocks -whenever there is more than one block per processor. +The boundary routines perform boundary +communications between blocks in CICE whether those blocks are on the +same or different MPI tasks. Neighbor data is communicated between +blocks via the ice_HaloUpdate method. The HaloUpdate also computes +values on the halo at the edge of the grid. Boundary conditions are defined by the ``ns_boundary_type`` and ``ew_boundary_type`` -namelist inputs. Valid values are ``open``, ``closed``, and ``cyclic``. In addition, +namelist inputs. Valid values are ``open``, ``closed``, ``cyclic``, ``zero_gradient``, +and ``linear_extrap``. In addition, ``tripole`` and ``tripoleT`` are options for the ``ns_boundary_type``. ``closed`` imposes a land mask on the boundary with a two gridcell depth -and is only supported for rectangular grids. In general, -where the boundary is land or where there is no ice on the boundary, +and is only supported for rectangular grids. ``zero_gradient`` and ``linear_extrap`` +apply boundary conditions of zero or constant gradient values based on +interior values near the boundary. ``cyclic`` boundary conditions communicate +neighbor data from the opposite side of the grid. ``open`` boundary conditions +do not impose any values on the boundary. This might be useful in cases where +external data is specified on the outside boundary. The ``zero_gradient`` and +``linear_extrap`` boundary conditions have been implemented as an interim step +toward a regional grid capability. Until restoring options are complete and the +regional capability is fully tested, these boundary conditions may produce +nonphysical values such as negative ice thickness. +In general, where the boundary is land or where there is no ice on the boundary, the boundary_type settings and boundary conditions play no role. In the displaced-pole global grids, the mask (kmt) file has at least one row of @@ -444,17 +455,15 @@ this example, the appropriate namelist settings are ``ns_boundary_type`` = ``open``, ``ew_boundary_type`` = ``cyclic``. -CICE can be run on regional grids with ``open``, ``closed``, or ``cyclic`` -boundary conditions. +CICE can be run on regional grids with ``open``, ``closed``, ``cyclic`` , ``zero_gradient``, +and ``linear_extrap`` boundary conditions. Except for variables describing grid lengths, non-land halo cells along the grid edge must be filled with some boundary conditions if ice is present at that location. The outside halo is handled automatically -with ``closed`` or ``cyclic`` conditions. With open boundary conditions, one can imagine +with ``closed``, ``cyclic``, ``zero_gradient``, or ``linear_extrap`` conditions. +With open boundary conditions, one can imagine several different ways to set the outside boundary including reading values from -an external file or deriving values on that halo based on the interior -solution while specifying zero gradient, constant gradient, specified state, -zero flux, or other boundary conditions. Mathematically specified boundary -conditions are currently not supported in the CICE model. +an external file. The namelist variable ``restore_ice`` turns on a restoring capability on the boundary by setting the boundary halo to values read from a file. The