создать MPI_Type_Struct для полиморфного производного типа - PullRequest
Новая
       38

создать MPI_Type_Struct для полиморфного производного типа

0 голосов
/ 25 октября 2019

Я предоставляю свои попытки создать тип данных MPI с MPI_Type_create_struct для отправки / получения типов OOP Fortran. Тип выглядит как 

type :: mytype
  integer             ::  id
  logical             ::  flag
  real,   allocatable ::  x(:)
  real,   allocatable ::  y(:)
 contains
  procedure, pass     ::  ctor => mytype_ctor
end type

и, следовательно, является производным типом с размещаемыми массивами и процедурами с привязкой к типу.

Как создать тип данных MPI для этого типа?

Я попробовал два vaiants, и ни один из них не сработал.

Первый вариант пытается явно установить карту типов из типов внутри производного типа mytype. Он использует MPI_Type_get_extent для расчета смещений. MPI_send и MPI_recv выполняются во время выполнения без ошибок. Но при доступе к массиву элементов x через write возникает ошибка времени выполнения SIGSEGV.

* * Второй вариант использует фиктивный экземпляр mytype для чтения начальных адресовчленов mytype напрямую. Типовая карта, которая возвращается - с моей точки зрения - ерунда. Адреса разбросаны по всему пространству адресов. Отправка и получение не работает во время выполнения. MPI_send приводит к SIGSEGV.

Существует ли стандартный способ переноса производных типов с назначаемыми элементами и процедурами через MPI?

Я использую mpifort(verion 18.0.5) для компиляции и запуска с mpirun -n 2 (версия 3.1.0). Минимальным примером являются следующие модуль и основная программа. 

module mod
use MPI
implicit none
save

  integer               ::  MPI_mytype_v1
  integer               ::  MPI_mytype_v2

  type :: mytype
    integer             ::  id
    logical             ::  flag
    real,   allocatable ::  x(:)
    real,   allocatable ::  y(:)
  contains
    procedure, pass     ::  ctor => mytype_ctor
  end type

contains

  subroutine mytype_ctor(this, nx, ny)
  implicit none
  class(mytype),  intent(inout) ::  this
  integer,      intent(in)    ::  nx, ny
    allocate(this%y(ny))
    allocate(this%x(nx))
  end subroutine

  subroutine MPI_create_mytype_v1(nx,ny)
  implicit none
  integer, intent(in) ::  nx, ny
    integer                         ::  types(4), bsize(4)
    integer(KIND=MPI_ADDRESS_KIND)  ::  displacement(4), types_extents(4), lb(4)
    integer i, err, rank

  bsize         = [ 1,                  1,                  nx,                  ny                 ]
  types         = [ MPI_INTEGER,        MPI_LOGICAL,        MPI_REAL,            MPI_REAL           ]

  do i=1, 4
    call MPI_Type_get_extent(types(i), lb(i), types_extents(i), err)
  enddo

  do i=1, 4
    displacement(i) = sum( bsize(1:i-1)*types_extents(1:i-1) )
  enddo

  call MPI_Comm_rank(MPI_COMM_WORLD, rank, err)
  if(rank==0) then
    write(*,'(a)'    ) 'creation with method 1 - layout'
    write(*,'(a,4I5)') 'size  ', bsize
    write(*,'(a,4I5)') 'type  ', types
    write(*,'(a,4I5)') 'extnt ', types_extents
    write(*,'(a,4I5)') 'displ ', displacement
  endif

  call MPI_Type_create_struct(4, bsize, displacement, types, MPI_mytype_v1, err)
  call MPI_Type_commit(MPI_mytype_v1, err);
  end subroutine


  subroutine MPI_create_mytype_v2(nx,ny)
  implicit none
  integer, intent(in) ::  nx, ny
    type(mytype)                    ::  MTdummy
    integer                         ::  types(4), bsize(4)
    integer(KIND=MPI_ADDRESS_KIND)  ::  displacement(4), address(4)
    integer i, err, rank

    bsize         = [ 1,                  1,                  nx,                  ny                 ]
    types         = [ MPI_INTEGER,        MPI_LOGICAL,        MPI_REAL,            MPI_REAL           ]


    call mytype_ctor(MTdummy, nx,ny)
    call MPI_get_Address(MTdummy%id,   address(1), err)
    call MPI_get_Address(MTdummy%flag, address(2), err)
    call MPI_get_Address(MTdummy%x(1), address(3), err)
    call MPI_get_Address(MTdummy%y(1), address(4), err)

    do i=1, 4
      displacement(i) = MPI_Aint_diff(address(i), address(1))
    enddo

    call MPI_Comm_rank(MPI_COMM_WORLD, rank, err)
    if(rank==0) then
      write(*,'(a)'     ) 'creation with method 2 - layout'
      write(*,'(a,4I5)' ) 'size    ', bsize
      write(*,'(a,4I5)' ) 'type    ', types
      write(*,'(a,4I25)') 'displ   ', displacement
      write(*,'(a,4I25)') 'adresses', address
    endif

    call MPI_Type_create_struct(4, bsize, displacement, types, MPI_mytype_v2, err)
    call MPI_Type_commit(MPI_mytype_v2, err);
  end subroutine

end module

program main
use mod
use MPI
implicit none
type(mytype)  ::  MT, MTrec
integer       ::  err, rank, n_procs

call MPI_Init(err)
call MPI_Comm_rank(MPI_COMM_WORLD, rank, err)
call MPI_Comm_size(MPI_COMM_WORLD, n_procs, err)

call MPI_create_mytype_v1(3,7)
call MPI_create_mytype_v2(3,7)

call mytype_ctor(MT,3,7)

if(rank==0) then
  MT%id    = 0
  MT%flag  = .true.
  MT%x(:)  = [+1,+2,+3]
  MT%y(:)  = [-1,-2,-3,-4,-5,-6,-7]
endif
if(rank==1) then
  MT%id    = 1
  MT%flag  = .false.
  MT%x(:)  = [0,0,0]
  MT%y(:)  = [0,1,2,4,8,16,32]
endif

if(rank==0) call MPI_Send( MT, 1, MPI_mytype_v1, 1, 1, MPI_COMM_WORLD, err)
! error on sending: if(rank==0) call MPI_Send( MT, 1, MPI_mytype_v2, 1, 2, MPI_COMM_WORLD, err)
if(rank==1) then
  call mytype_ctor(MTrec,3,7)
  call MPI_Recv( MTrec, 1, MPI_mytype_v1, 0, 1, MPI_COMM_WORLD,  MPI_STATUS_IGNORE, err)
  ! call MPI_Recv( MTrec, 1, MPI_mytype_v2, 0, 2, MPI_COMM_WORLD,  MPI_STATUS_IGNORE, err)
  write(*,'(a,I0)')  'received id  ', MTrec%id
  write(*,'(a,L)' )  'received flag', MTrec%flag
  write(*,'(a,L)' )  'is x alloc?  ', allocated(MTrec%x)
  write(*,'(a,G0)')  'received x   ', MTrec%x(1)
  write(*,'(a,G0)')  'received x   ', MTrec%x(2)
  write(*,'(a,G0)')  'received x   ', MTrec%x(3)
  write(*,'(a,7G0)') 'received y   ', MTrec%y
endif

call MPI_finalize(err)
end program

Макет fixed выглядит как разумная карта типов. 

creation with method 1 - layout
size      1    1    3    7
type      7    6   13   13
extnt     4    4    4    4
displ     0    4    8   20

Макет изПоиск адреса MPI кажется ошибочным. 

creation with method 2 - layout
size        1    1    3    7
type        7    6   13   13
displ                           0                        4         -140732799234248         -140732798626120
adresses          140732823825384          140732823825388                 24591136                 25199264

При выполнении с первым вариантом тип данных получает отправку и получение. Запись его членов (и тест для выделения массива элементов x) дает: 

received id  0
received flag T
is x alloc?   T
forrtl: severe (174): SIGSEGV, segmentation fault occurred
...