psmile_global_sum.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2009, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION
! Subroutines psmile_global_sum_compute_* compute the sum of
! all elements in a given field on all processes within the
! given communicator.
! Subroutines psmile_global_sum_[send,recv]_* handle the
! sending and receiving of global sums between the local
! process and the transformer.
! The subroutine ddadd_mpi_callback is used for generating a
! user-defined MPI operation, which is similar to MPI_SUM but
! has higher accurary
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 07/12/2009  M. Hanke     Creation

subroutine psmile_global_sum_compute_dble(data, data_size, nbr_fields, comm, global_sum, ierror)
   use PRISM
   use PSMILe, dummy_interface => psmile_global_sum_compute_dble
   implicit none

   integer, intent (in)           :: data_size
   integer, intent (in)           :: nbr_fields
   double complex, intent(in)     :: data(data_size, nbr_fields)
   integer, intent (in)           :: comm
   double complex, intent (out)   :: global_sum(nbr_fields)

   integer, intent (out)          :: ierror
   integer                        :: ierrp (3)

   integer                        :: i, j
   double complex                 :: local_sum(nbr_fields)

   !compute local sum
   !the number of additions could be reduced to log2(data_size)
   local_sum = 0.0

   do i = 1, nbr_fields
      do j = 1, data_size
         call psmile_ddadd(data(j,i), local_sum(i))
      enddo
   enddo

   !compute global sum using mpi_reduce

!   call MPI_Allreduce (local_sum, global_sum, nbr_fields, MPI_DOUBLE_PRECISION, &
!                       MPI_SUM, comm, ierror)
   call MPI_Allreduce (local_sum, global_sum, nbr_fields, MPI_DOUBLE_COMPLEX, &
                       PSMILE_MPI_SUMDD, comm, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif

   ierror = 0
end subroutine psmile_global_sum_compute_dble

subroutine psmile_global_sum_compute_int(data, data_size, nbr_fields, comm, global_sum, ierror)
   use PRISM
   use PSMILe, dummy_interface => psmile_global_sum_compute_int
   implicit none

   integer, intent (in)          :: data_size
   integer, intent (in)          :: nbr_fields
   integer, intent(in)           :: data(data_size, nbr_fields)
   integer, intent (in)          :: comm
   integer, intent (out)         :: global_sum(nbr_fields)

   integer, intent (out)         :: ierror
   integer                       :: ierrp (3)

   integer                       :: i, j
   integer                       :: local_sum(nbr_fields)
   integer, parameter            :: dummy = 0

   !compute local sum
   !the number of additions could be reduced to log2(data_size)

   local_sum = 0.0

   do i = 1, nbr_fields
      local_sum(i) = sum(data(:,i))
   enddo

   !compute global sum using mpi_reduce

   call MPI_Allreduce (local_sum, global_sum, nbr_fields, MPI_INTEGER, &
                       MPI_SUM, comm, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif

   ierror = 0
end subroutine psmile_global_sum_compute_int

subroutine psmile_global_sum_send_dble(data, nbr_fields, rank, ierror)
   use PRISM
   use PRISM_constants
   use PSMILe, dummy_interface => psmile_global_sum_send_dble
   implicit none

   integer, intent(in)          :: nbr_fields
   double complex, intent(in)   :: data(nbr_fields)
   integer, intent(in)          :: rank

   integer, intent(out)         :: ierror
   integer                      :: ierrp (3)

    CALL MPI_Send(data(1), nbr_fields, MPI_DOUBLE_COMPLEX, rank, &
                 CONSERVTAG, comm_trans, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif
end subroutine psmile_global_sum_send_dble

subroutine psmile_global_sum_send_int(data, nbr_fields, rank, ierror)
   use PRISM
   use PRISM_constants
   use PSMILe, dummy_interface => psmile_global_sum_send_int
   implicit none

   integer, intent(in)        :: nbr_fields
   integer, intent(in)        :: data(nbr_fields)
   integer, intent(in)        :: rank

   integer, intent(out)       :: ierror
   integer                    :: ierrp (3)

   CALL MPI_Send(data(1), nbr_fields, MPI_INTEGER, rank, &
                 CONSERVTAG, comm_trans, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif
end subroutine psmile_global_sum_send_int

subroutine psmile_global_sum_recv_dble(data, nbr_fields, rank, ierror)
   use PRISM
   use PRISM_constants
   use PSMILe, dummy_interface => psmile_global_sum_recv_dble
   implicit none

   integer, intent(in)          :: nbr_fields
   double complex, intent(out)  :: data(nbr_fields)
   integer, intent(in)          :: rank

   integer                      :: status(MPI_STATUS_SIZE)
   integer, intent(out)         :: ierror
   integer                      :: ierrp (3)

   CALL MPI_Recv(data, nbr_fields, MPI_DOUBLE_COMPLEX, rank, &
                 CONSERVTAG, comm_trans, status, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif
end subroutine psmile_global_sum_recv_dble

subroutine psmile_global_sum_recv_int(data, nbr_fields, rank, ierror)
   use PRISM
   use PRISM_constants
   use PSMILe, dummy_interface => psmile_global_sum_recv_int
   implicit none

   integer, intent(in)          :: nbr_fields
   integer, intent(out)         :: data(nbr_fields)
   integer, intent(in)          :: rank

   integer                      :: status(MPI_STATUS_SIZE)
   integer, intent(out)         :: ierror
   integer                      :: ierrp (3)

   CALL MPI_Recv(data, nbr_fields, MPI_INTEGER, rank, &
                 CONSERVTAG, comm_trans, status, ierror)

   if (ierror /= MPI_SUCCESS) then
      ierror = PRISM_Error_MPI
      ierrp  = ierror

      call psmile_error (ierror, 'PSMILE_COMPUTE_GLOBAL_SUM', &
                         ierrp, 1, __FILE__, __LINE__ )
     return
   endif
end subroutine psmile_global_sum_recv_int

subroutine psmile_ddadd_mpi_callback (dda, ddb, len, itype)
   use PSMILe, dummy_interface => psmile_ddadd_mpi_callback
   implicit none

   integer, intent(in)           :: len, itype
   double complex, intent(in)    :: dda(len)
   double complex, intent(inout) :: ddb(len)

   integer                       :: i

   do i = 1, len

      ! calls C routine which does the addition
      call psmile_ddadd(dda(i), ddb(i))

   enddo

end subroutine psmile_ddadd_mpi_callback