Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Update global reduction implementation to improve performance, fix VP bug #824

Merged
merged 2 commits into from
Apr 5, 2023
Merged

Update global reduction implementation to improve performance, fix VP bug #824

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b952c2f
Update global reduction implementation to improve performance, fix VP…
apcraig Mar 31, 2023
0c40845
Update VP global sum to exclude local implementation with tripole grids
apcraig Apr 5, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 2 additions & 4 deletions cicecore/cicedyn/analysis/ice_diagnostics.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -261,10 +261,8 @@ subroutine runtime_diags (dt)
!$OMP END PARALLEL DO
extentn = c0
extents = c0
extentn = global_sum(work1, distrb_info, field_loc_center, &
tarean)
extents = global_sum(work1, distrb_info, field_loc_center, &
tareas)
extentn = global_sum(work1, distrb_info, field_loc_center, tarean)
extents = global_sum(work1, distrb_info, field_loc_center, tareas)
extentn = extentn * m2_to_km2
extents = extents * m2_to_km2

Expand Down
41 changes: 21 additions & 20 deletions cicecore/cicedyn/dynamics/ice_dyn_vp.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2502,7 +2502,7 @@ function global_dot_product (nx_block , ny_block , &
vector2_x , vector2_y) &
result(dot_product)

use ice_domain, only: distrb_info
use ice_domain, only: distrb_info, ns_boundary_type
use ice_domain_size, only: max_blocks
use ice_fileunits, only: bfbflag

Expand Down Expand Up @@ -2552,8 +2552,14 @@ function global_dot_product (nx_block , ny_block , &
enddo
!$OMP END PARALLEL DO

! Use local summation result unless bfbflag is active
if (bfbflag == 'off') then
! Use faster local summation result for several bfbflag settings.
! The local implementation sums over each block, sums over local
! blocks, and calls global_sum on a scalar and should be just as accurate as
! bfbflag = 'off', 'lsum8', and 'lsum4' without the extra copies and overhead
! in the more general array global_sum. But use the array global_sum
! if bfbflag is more strict or for tripole grids (requires special masking)
if (ns_boundary_type /= 'tripole' .and. ns_boundary_type /= 'tripoleT' .and. &
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just added this check on tripole grids. Don't want to use the local sum with tripole grids because special masking is required. Reran full test suite on cheyenne with gnu compiler and should be good.

(bfbflag == 'off' .or. bfbflag == 'lsum8' .or. bfbflag == 'lsum4')) then
dot_product = global_sum(sum(dot), distrb_info)
else
dot_product = global_sum(prod, distrb_info, field_loc_NEcorner)
Expand Down Expand Up @@ -3120,7 +3126,7 @@ subroutine fgmres (zetax2 , etax2 , &
j = indxUj(ij, iblk)

workspace_x(i, j, iblk) = workspace_x(i, j, iblk) + rhs_hess(it) * arnoldi_basis_x(i, j, iblk, it)
workspace_y(i, j, iblk) = workspace_x(i, j, iblk) + rhs_hess(it) * arnoldi_basis_y(i, j, iblk, it)
workspace_y(i, j, iblk) = workspace_y(i, j, iblk) + rhs_hess(it) * arnoldi_basis_y(i, j, iblk, it)
enddo ! ij
enddo
!$OMP END PARALLEL DO
Expand Down Expand Up @@ -3151,7 +3157,6 @@ subroutine pgmres (zetax2 , etax2 , &

use ice_boundary, only: ice_HaloUpdate
use ice_domain, only: maskhalo_dyn, halo_info
use ice_fileunits, only: bfbflag
use ice_timers, only: ice_timer_start, ice_timer_stop, timer_bound

real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks,4), intent(in) :: &
Expand Down Expand Up @@ -3343,21 +3348,17 @@ subroutine pgmres (zetax2 , etax2 , &
workspace_x , workspace_y)

! Update workspace with boundary values
! NOTE: skipped for efficiency since this is just a preconditioner
! unless bfbflag is active
if (bfbflag /= 'off') then
call stack_fields(workspace_x, workspace_y, fld2)
call ice_timer_start(timer_bound)
if (maskhalo_dyn) then
call ice_HaloUpdate (fld2, halo_info_mask, &
field_loc_NEcorner, field_type_vector)
else
call ice_HaloUpdate (fld2, halo_info, &
field_loc_NEcorner, field_type_vector)
endif
call ice_timer_stop(timer_bound)
call unstack_fields(fld2, workspace_x, workspace_y)
call stack_fields(workspace_x, workspace_y, fld2)
call ice_timer_start(timer_bound)
if (maskhalo_dyn) then
call ice_HaloUpdate (fld2, halo_info_mask, &
field_loc_NEcorner, field_type_vector)
else
call ice_HaloUpdate (fld2, halo_info, &
field_loc_NEcorner, field_type_vector)
endif
call ice_timer_stop(timer_bound)
call unstack_fields(fld2, workspace_x, workspace_y)

!$OMP PARALLEL DO PRIVATE(iblk)
do iblk = 1, nblocks
Expand Down Expand Up @@ -3528,7 +3529,7 @@ subroutine pgmres (zetax2 , etax2 , &
j = indxUj(ij, iblk)

workspace_x(i, j, iblk) = workspace_x(i, j, iblk) + rhs_hess(it) * arnoldi_basis_x(i, j, iblk, it)
workspace_y(i, j, iblk) = workspace_x(i, j, iblk) + rhs_hess(it) * arnoldi_basis_y(i, j, iblk, it)
workspace_y(i, j, iblk) = workspace_y(i, j, iblk) + rhs_hess(it) * arnoldi_basis_y(i, j, iblk, it)
enddo ! ij
enddo
!$OMP END PARALLEL DO
Expand Down
60 changes: 32 additions & 28 deletions cicecore/cicedyn/infrastructure/comm/mpi/ice_exit.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@

!=======================================================================
!
! Exit the model.
Expand All @@ -8,7 +9,15 @@
module ice_exit

use ice_kinds_mod
use ice_fileunits, only: nu_diag, ice_stderr, flush_fileunit
use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted
#if (defined CESMCOUPLED)
use shr_sys_mod
#else
#ifndef SERIAL_REMOVE_MPI
use mpi ! MPI Fortran module
#endif
#endif

implicit none
public
Expand All @@ -23,70 +32,65 @@ subroutine abort_ice(error_message, file, line, doabort)

! This routine aborts the ice model and prints an error message.

#if (defined CESMCOUPLED)
use ice_fileunits, only: nu_diag, flush_fileunit
use shr_sys_mod
#else
use ice_fileunits, only: nu_diag, ice_stderr, flush_fileunit
use mpi ! MPI Fortran module
#endif

character (len=*), intent(in),optional :: error_message ! error message
character (len=*), intent(in),optional :: file ! file
integer (kind=int_kind), intent(in), optional :: line ! line number
logical (kind=log_kind), intent(in), optional :: doabort ! abort flag

! local variables

#ifndef CESMCOUPLED
integer (int_kind) :: &
ierr, & ! MPI error flag
outunit, & ! output unit
error_code ! return code
#endif
logical (log_kind) :: ldoabort ! local doabort flag
character(len=*), parameter :: subname='(abort_ice)'

ldoabort = .true.
if (present(doabort)) ldoabort = doabort

#if (defined CESMCOUPLED)
call flush_fileunit(nu_diag)
call icepack_warnings_flush(nu_diag)
write(nu_diag,*) ' '
write(nu_diag,*) subname, 'ABORTED: '
if (present(file)) write (nu_diag,*) subname,' called from ',trim(file)
if (present(line)) write (nu_diag,*) subname,' line number ',line
if (present(error_message)) write (nu_diag,*) subname,' error = ',trim(error_message)
call flush_fileunit(nu_diag)
if (ldoabort) call shr_sys_abort(subname//trim(error_message))
outunit = nu_diag
#else
outunit = ice_stderr
#endif

call flush_fileunit(nu_diag)
call icepack_warnings_flush(nu_diag)
write(ice_stderr,*) ' '
write(ice_stderr,*) subname, 'ABORTED: '
if (present(file)) write (ice_stderr,*) subname,' called from ',trim(file)
if (present(line)) write (ice_stderr,*) subname,' line number ',line
if (present(error_message)) write (ice_stderr,*) subname,' error = ',trim(error_message)
call flush_fileunit(ice_stderr)
error_code = 128
write(outunit,*) ' '
write(outunit,*) subname, 'ABORTED: '
if (present(file)) write (outunit,*) subname,' called from ',trim(file)
if (present(line)) write (outunit,*) subname,' line number ',line
if (present(error_message)) write (outunit,*) subname,' error = ',trim(error_message)
call flush_fileunit(outunit)

if (ldoabort) then
#if (defined CESMCOUPLED)
call shr_sys_abort(subname//trim(error_message))
#else
#ifndef SERIAL_REMOVE_MPI
error_code = 128
call MPI_ABORT(MPI_COMM_WORLD, error_code, ierr)
#endif
stop
endif
#endif
endif

end subroutine abort_ice

!=======================================================================

subroutine end_run

! Ends run by calling MPI_FINALIZE.
! Ends run by calling MPI_FINALIZE
! Does nothing in serial runs

integer (int_kind) :: ierr ! MPI error flag
character(len=*), parameter :: subname = '(end_run)'

#ifndef SERIAL_REMOVE_MPI
call MPI_FINALIZE(ierr)
#endif

end subroutine end_run

Expand Down
Loading