How to MPI broadcast things like character(:), allocatable :: str?

1

Dear all,

As an extremely simple example, I define

 type :: var_char
   character(:), allocatable :: str    
 end type var_char
 type(var_char) :: test_type

I want to broadcast

test_type%str

However since str is character(:), allocatable :: str , I am not sure how to do it with the minimal effort.
Does anyone know how to broadcast such a str?
Thank you very much indeed!

However if I set str as fixed length like

character(len=120) :: str

I can use my bcastchar(w) subroutine to do it,

   subroutine bcastchar(w)
   integer(kind=i4) :: ierror
   character(len=*) :: w
   call mpi_bcast(w,len(w),mpi_character,0,mpi_comm_world,ierror)
   return
   end subroutine bcastchar

Is there a way to modify my bcastchar(w) to allow character(:), allocatable :: str as well?

The minimal code is below, I compile using intel OneAPI 2021.4.
Obviously currently I cannot broadcast str correctly and it gives an error. Other than rank0, other ranks cannot recognize str correctly.

program mpi_obj_bcast
  use mympi
	implicit none 
  type :: var_char
    character(:), allocatable :: str    
  end type var_char
  type(var_char) :: test_type
integer :: i
   
  call init0 !mpi initialization   
  if (myrank()==0) then ! setting test_type%str
    write (6,*) 'rank 0 set test_type%str as stupid'
    test_type%str = 'stupid'
  endif
  
  call bcast(test_type%str) ! broadcast from rank 0 to all the rest ranks.
  do i=0,nproc()-1 ! all the ranks display test_type%str
    if (myrank()==i) then
      write (6,*) 'rank = ', myrank()
      write (6,*) 'test_type%str = ', test_type%str
    endif
  call barrier  
  enddo  

! finalize  
  if (myrank().eq.0) write(6,*) 'The program end normally!'
  call barrier 
  call done
  
end program mpi_obj_bcast

My mympi module as a wrapper of MPI is,

module mympi
   implicit none
   include 'mpif.h'
   integer, private, parameter :: i4=selected_int_kind(9)
   integer, private, parameter :: i8=selected_int_kind(15)
   integer, private, parameter :: r8=selected_real_kind(15,9)
   integer, private, save :: mpii4,mpii8,mpir8
   integer(kind=i4), private, save :: irank,iproc

interface bcast ! broadcast from process 0
   module procedure bcastirn
   module procedure bcasti1,bcasti1d,bcasti2d,bcasti3d,bcasti4d
   module procedure bcastr1,bcastr1d,bcastr2d,bcastr3d,bcastr4d
   module procedure bcastlogi
   module procedure bcastchar
end interface bcast

interface addall ! return sum to process 0
   module procedure addalli1,addalli1d,addalli1_8,addalli1d_8
   module procedure addallr1,addallr1d,addallr2d
   module procedure addallc1,addallc1d
end interface addall

interface gather ! gather to process 0
   module procedure gatheri1,gatheri1d,gatheri81
   module procedure gatherr1,gatherr1d
end interface gather

interface scatter ! scatter from process 0 to all process, evenly scatter. inverse of gather
   module procedure scatteri1,scatteri1d,scatteri81
   module procedure scatterr1,scatterr1d
end interface scatter

interface send ! send to someone else
   module procedure sendi1,sendi1d
   module procedure sendr1,sendr1d
   module procedure sendc1,sendc1d
end interface send

interface recv ! recv from someone else
   module procedure recvi1,recvi1d
   module procedure recvr1,recvr1d
   module procedure recvc1,recvc1d
end interface recv

contains
   subroutine init0 ! call this before anything else
   use mpi
   integer :: ierror,isize,ir,ip
   integer(kind=i4) :: itest4
   integer(kind=i8) :: itest8
   real(kind=r8) :: rtest8
   call mpi_init(ierror)
   call mpi_comm_rank(mpi_comm_world,ir,ierror)
   irank=ir
   call mpi_comm_size(mpi_comm_world,ip,ierror)
   iproc=ip
   call mpi_sizeof(itest4,isize,ierror)
   call mpi_type_match_size(mpi_typeclass_integer,isize,mpii4,ierror)
   call mpi_sizeof(itest8,isize,ierror)
   call mpi_type_match_size(mpi_typeclass_integer,isize,mpii8,ierror)
   call mpi_sizeof(rtest8,isize,ierror)
   call mpi_type_match_size(mpi_typeclass_real,isize,mpir8,ierror)
   return
   end subroutine init0

   subroutine done ! wrapper for finalize routine
   integer :: ierror
   call mpi_finalize(ierror)
   return
   end subroutine done

   subroutine bcastlogi(i)
   logical :: i
   integer :: ierror
   call mpi_bcast(i,1,mpi_logical,0,mpi_comm_world,ierror)
   return
   end subroutine bcastlogi   
   
   subroutine bcastirn(i)
   integer(kind=i8) :: i
   integer :: ierror
   call mpi_bcast(i,1,mpii8,0,mpi_comm_world,ierror)
   return
   end subroutine bcastirn

   subroutine bcasti1(i)
   integer(kind=i4) :: i
   integer :: ierror
   call mpi_bcast(i,1,mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine bcasti1

   subroutine bcasti1d(i)
   integer(kind=i4) :: i(:)
   integer :: ierror
   call mpi_bcast(i,size(i),mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine bcasti1d

   subroutine bcasti2d(i)
   integer(kind=i4) :: i(:,:)
   integer :: ierror
   call mpi_bcast(i,size(i),mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine bcasti2d

   subroutine bcasti3d(i)
   integer(kind=i4) :: i(:,:,:)
   integer :: ierror
   call mpi_bcast(i,size(i),mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine bcasti3d

   subroutine bcasti4d(i)
   integer(kind=i4) :: i(:,:,:,:)
   integer :: ierror
   call mpi_bcast(i,size(i),mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine bcasti4d

   subroutine bcastr1d(r)
   real(kind=r8) :: r(:)
   integer :: ierror
   call mpi_bcast(r,size(r),mpir8,0,mpi_comm_world,ierror)
   return
   end subroutine bcastr1d

   subroutine bcastr2d(r)
   real(kind=r8) :: r(:,:)
   integer :: ierror
   call mpi_bcast(r,size(r),mpir8,0,mpi_comm_world,ierror)
   return
   end subroutine bcastr2d

   subroutine bcastr3d(r)
   real(kind=r8) :: r(:,:,:)
   integer :: ierror
   call mpi_bcast(r,size(r),mpir8,0,mpi_comm_world,ierror)
   end subroutine bcastr3d

   subroutine bcastr4d(r)
   real(kind=r8) :: r(:,:,:,:)
   integer :: ierror
   call mpi_bcast(r,size(r),mpir8,0,mpi_comm_world,ierror)
   end subroutine bcastr4d

   subroutine bcastr1(r)
   real(kind=r8) :: r
   integer :: ierror
   call mpi_bcast(r,1,mpir8,0,mpi_comm_world,ierror)
   end subroutine bcastr1

   subroutine bcastchar(w)
   integer(kind=i4) :: ierror
   character(len=*) :: w
   call mpi_bcast(w,len(w),mpi_character,0,mpi_comm_world,ierror)
   return
   end subroutine bcastchar   
   
   
   function myrank() ! which process am I?
   integer(kind=i4) :: myrank
   myrank=irank
   return
   end function myrank

   function nproc() ! How many of use are there anyway?
   integer(kind=i4) :: nproc
   nproc=iproc
   return
   end function nproc

   subroutine addalli1(i,isum)
   integer(kind=i4) :: ierror,i,isum
   call mpi_reduce(i,isum,1,mpi_integer,mpi_sum,0,mpi_comm_world,ierror)
   return
   end subroutine addalli1

   subroutine addalli1d(i,isum)
   integer(kind=i4) :: ierror,i(:),isum(:)
   call mpi_reduce(i,isum,size(i),mpi_integer,mpi_sum,0,mpi_comm_world,ierror)
   return
   end subroutine addalli1d
   
   subroutine addalli1_8(i,isum)
   integer(kind=i4) :: ierror
   integer(kind=i8) :: i,isum
   call mpi_reduce(i,isum,1,mpi_integer8,mpi_sum,0,mpi_comm_world,ierror)
   return
   end subroutine addalli1_8

   subroutine addalli1d_8(i,isum)
   integer(kind=i4) :: ierror
   integer(kind=i8) :: i(:),isum(:)
   call mpi_reduce(i,isum,size(i),mpi_integer8,mpi_sum,0,mpi_comm_world,ierror)
   return
   end subroutine addalli1d_8

   subroutine addallr1(r,rsum)
   integer(kind=i4) :: ierror
   real(kind=r8) :: r,rsum
   call mpi_reduce(r,rsum,1,mpi_double_precision,mpi_sum,0, &
      mpi_comm_world,ierror)
   return
   end subroutine addallr1

   subroutine addallr1d(r,rsum)
   real(kind=r8) :: r(:),rsum(:)
   integer(kind=i4) :: ierror
   call mpi_reduce(r,rsum,size(r),mpi_double_precision,mpi_sum,0, &
      mpi_comm_world,ierror)
   return
   end subroutine addallr1d

   subroutine addallr2d(r,rsum)
   real(kind=r8) :: r(:,:),rsum(:,:)
   integer(kind=i4) :: ierror
   call mpi_reduce(r,rsum,size(r),mpi_double_precision,mpi_sum,0, &
      mpi_comm_world,ierror)
   return
   end subroutine addallr2d

   subroutine addallc1(c,csum)
   integer(kind=i4) :: ierror
   complex(kind=r8) :: c,csum
   call mpi_reduce(c,csum,1,mpi_double_complex,mpi_sum,0, &
      mpi_comm_world,ierror)
   return
   end subroutine addallc1

   subroutine addallc1d(c,csum)
   complex(kind=r8) :: c(:),csum(:)
   integer(kind=i4) :: ierror
   call mpi_reduce(c,csum,size(c),mpi_double_complex,mpi_sum,0, &
      mpi_comm_world,ierror)
   return
   end subroutine addallc1d

   subroutine gatheri1(i,igather)
   integer(kind=i4) :: i,igather(:)
   integer :: ierror
   call mpi_gather(i,1,mpii4,igather,1,mpii4,0,mpi_comm_world,ierror)
   return
   end subroutine gatheri1

   subroutine gatheri1d(i,igather)
   integer(kind=i4) :: i(:),igather(:)
   integer :: ierror
   call mpi_gather(i,size(i),mpii4,igather,size(i),mpii4,0, &
      mpi_comm_world,ierror)
   return
   end subroutine gatheri1d

   subroutine gatheri81(i,igather)
   integer(kind=i8) :: i,igather(:)
   integer :: ierror
   call mpi_gather(i,1,mpii8,igather,1,mpii8,0, &
      mpi_comm_world,ierror)
   return
   end subroutine gatheri81   

   subroutine gatherr1(r,rgather)
   real(kind=r8) :: r,rgather(:)
   integer :: ierror
   call mpi_gather(r,1,mpir8,rgather,1,mpir8,0,mpi_comm_world,ierror)
   return
   end subroutine gatherr1

   subroutine gatherr1d(r,rgather)
   real(kind=r8) :: r(:),rgather(:)
   integer :: ierror
   call mpi_gather(r,size(r),mpir8,rgather,size(r),mpir8,0, &
      mpi_comm_world,ierror)
   return
   end subroutine gatherr1d
  
   subroutine scatteri1(i,iscatter)
   integer(kind=i4) :: i(:),iscatter
   integer :: ierror   
   call mpi_scatter(i,1,mpii4,iscatter,1,mpii4,0, &
      mpi_comm_world,ierror)  
   return
   end subroutine scatteri1    
   
   subroutine scatteri81(i,iscatter)
   integer(kind=i8) :: i(:),iscatter
   integer :: ierror   
   call mpi_scatter(i,1,mpii8,iscatter,1,mpii8,0, &
      mpi_comm_world,ierror)  
   return
   end subroutine scatteri81
   
   subroutine scatteri1d(i,iscatter)
   integer(kind=i4) :: i(:),iscatter(:)
   integer :: ierror
   call mpi_scatter(i,size(iscatter),mpii4,iscatter,size(iscatter),mpii4,0, &
      mpi_comm_world,ierror) 
   return
   end subroutine scatteri1d
   
   subroutine scatterr1(r,rscatter)
   real(kind=r8) :: r(:),rscatter
   integer :: ierror
   call mpi_scatter(r,1,mpir8,rscatter,1,mpir8,0, &
      mpi_comm_world,ierror)
   return
   end subroutine scatterr1   
   
   subroutine scatterr1d(r,rscatter)
   real(kind=r8) :: r(:),rscatter(:)
   integer :: ierror
   call mpi_scatter(r,size(rscatter),mpir8,rscatter,size(rscatter),mpir8,0, &
      mpi_comm_world,ierror)
   return
   end subroutine scatterr1d   
   
   subroutine sendi1(i,idto,itag)
   integer(kind=i4) :: i,idto,itag,ierror
   call mpi_send(i,1,mpi_integer,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendi1

   subroutine sendi1d(i,idto,itag)
   integer(kind=i4) :: i(:),idto,itag,ierror
   call mpi_send(i,size(i),mpi_integer,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendi1d

   subroutine sendr1(r,idto,itag)
   integer(kind=i4) :: idto,itag,ierror
   real(kind=r8) :: r
   call mpi_send(r,1,mpi_double_precision,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendr1

   subroutine sendr1d(r,idto,itag)
   integer(kind=i4) :: idto,itag,ierror
   real(kind=r8) :: r(:)
   call mpi_send(r,size(r),mpi_double_precision,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendr1d

   subroutine sendc1(c,idto,itag)
   integer(kind=i4) :: idto,itag,ierror
   complex (kind=r8) :: c
   call mpi_send(c,1,mpi_double_complex,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendc1

   subroutine sendc1d(c,idto,itag)
   integer(kind=i4) :: idto,itag,ierror
   complex(kind=r8) :: c(:)
   call mpi_send(c,size(c),mpi_double_complex,idto,itag,mpi_comm_world,ierror)
   return
   end subroutine sendc1d

   subroutine recvi1(i,idfrom,itag)
   integer(kind=i4) :: i,idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   call mpi_recv(i,1,mpi_integer,idfrom,itag,mpi_comm_world,status,ierror)
   return
   end subroutine recvi1

   subroutine recvi1d(i,idfrom,itag)
   integer(kind=i4) :: i(:),idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   call mpi_recv(i,size(i),mpi_integer,idfrom,itag,mpi_comm_world,status,ierror)
   return
   end subroutine recvi1d

   subroutine recvr1(r,idfrom,itag)
   integer(kind=i4) :: idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   real(kind=r8) :: r
   call mpi_recv(r,1,mpi_double_precision,idfrom,itag,mpi_comm_world,status,ierror)
   return
   end subroutine recvr1

   subroutine recvr1d(r,idfrom,itag)
   integer(kind=i4) :: idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   real(kind=r8) :: r(:)
   call mpi_recv(r,size(r),mpi_double_precision,idfrom,itag,mpi_comm_world, &
      status,ierror)
   return
   end subroutine recvr1d

   subroutine recvc1(c,idfrom,itag)
   integer(kind=i4) :: idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   complex (kind=r8) :: c
   call mpi_recv(c,1,mpi_double_complex,idfrom,itag,mpi_comm_world,status,ierror)
   return
   end subroutine recvc1

   subroutine recvc1d(c,idfrom,itag)
   integer(kind=i4) :: idfrom,itag,ierror,STATUS(MPI_STATUS_SIZE)  
   complex(kind=r8) :: c(:)
   call mpi_recv(c,size(c),mpi_double_complex,idfrom,itag,mpi_comm_world,status,ierror)
   return
   end subroutine recvc1d   
   
   subroutine barrier ! wrapper for mpi_barrier
   integer(kind=i4) :: ierror
   call mpi_barrier(mpi_comm_world,ierror)
   return
   end subroutine barrier   
   
   subroutine abort
   integer :: ierror
   call mpi_abort(mpi_comm_world,ierror)
   !stop
   return
   end subroutine abort

   subroutine mpiwait
   integer :: REQUEST, STATUS(MPI_STATUS_SIZE), IERROR
   call MPI_WAIT(REQUEST, STATUS, IERROR)
   return
   end subroutine mpiwait   
   
   
 
end module mympi
1 Like
3

@septc Thank you very much indeed for your suggestion! broadcast the length of str is a brilliant idea!

Yeah, currently what I wanted to do is that use a single subroutine which can broadcast both fixed length str and allocatable length str, therefore there will not be ambiguity when do overloading for bcast().

The fixed length str version can be

   subroutine bcastchar(w)
   integer(kind=i4) :: ierror
   character(len=*) :: w
   call mpi_bcast(w,len(w),mpi_character,0,mpi_comm_world,ierror)
   return
   end subroutine bcastchar

The allocatable str version can be yours which are brilliant by the way!

But I tried a little and currently did not find a way write a subroutine which can handle both situation.
I have tried the code below to combine fixed length str and allocatable length str. It works for fixed length str but not for allocatable length str, and the problem is described in the comment line.

   subroutine bcastchar(w)
   integer(kind=i4) :: ierror
   character(len=*) :: w
   character(:), allocatable :: wa
   integer(kind=i4) :: wlen   
   if (myrank()==0) then
     wlen = len(w)
      if (allocated(wa)) deallocate(wa)
      allocate( character(wlen) :: wa )
     wa = w
   endif 
   call bcast(wlen)
   if (myrank()/=0) then
      if (allocated(wa)) deallocate(wa)
      allocate( character(wlen) :: wa )
   endif   
   call mpi_bcast(wa,wlen,mpi_character,0,mpi_comm_world,ierror)
   if (myrank()/=0) then
     w = wa  !---> the problem is when the input w is character(:), allocatable, for ranks other than 0, the w here is of length 0, so w = wa does not set w to wa. Unless w is initialized with the correct length before call this subroutine.
   endif
   return
   end subroutine bcastchar
1 Like
4

I am sorry to be very late for reply, and yes, I am afraid the above code (for character(:) dummy argument) does not work for an actual allocatable character argument (because the dummy argument no longer has the allocatable attribute).

A workaround may be to use some derived type that contains an allocatable character as a component (like “string type” as often discussed in other threads). After all, I believe such a string type should be available as a built-in feature for more flexible programming, rather than requiring the users to search and install it from additional libraries.

5

I have written something similar, it works if the string is of unknown size:

subroutine parallelization_bcast_str(string)                                                        
                                                                                                    
  character(len=:), allocatable, intent(inout) :: string                                            
                                                                                                    
  integer(MPI_INTEGER_KIND) :: strlen, err_MPI                                                      
                                                                                                    
                                                                                                    
  if (worldrank == 0) strlen = len(string,MPI_INTEGER_KIND)                                         
  call MPI_Bcast(strlen,1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI)  
  if (worldrank /= 0) allocate(character(len=strlen)::string)                                       
                                                                                                    
  call MPI_Bcast(string,strlen,MPI_CHARACTER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI)            
                                                                                                    
                                                                                                    
end subroutine parallelization_bcast_str

If the string length is known before, MPI_Bcast can be directly used to broadcast a string.

2 Likes