source: codes/icosagcm/devel/src/unstructured/transfer_unstructured.F90 @ 681

MODULE transfer_unstructured_mod
  USE data_unstructured_mod
  IMPLICIT NONE
  SAVE
  PRIVATE

  INCLUDE 'mpif.h'
  
  PUBLIC :: update_halo
  
CONTAINS

  SUBROUTINE init_halo_transfer(halo, rank, num, cells)
    TYPE(Halo_transfer) :: halo
    INTEGER :: ranks, total, rank(:), num(:), cells(:)
    ranks=SIZE(rank)
    total=SIZE(cells)
    IF(total /= SUM(num) ) STOP 'init_halo_transfer : SIZE(cells)<>SUM(num)'
    halo%ranks = ranks
    ALLOCATE(halo%rank(ranks))
    ALLOCATE(halo%num(ranks))
    ALLOCATE(halo%cells(total))
    ALLOCATE(halo%buf2(llm+1,total))
    halo%rank=rank
    halo%num=num
    halo%cells=cells
  END SUBROUTINE init_halo_transfer

  SUBROUTINE init_transfer(index, &
       send_num, send_size, send_rank, send_len, send_list, &
       recv_num, recv_size, recv_rank, recv_len, recv_list) &
       BIND(C, name='dynamico_init_transfer')
    INTEGER(C_INT), VALUE :: index, send_num, send_size, recv_num, recv_size
    INTEGER(C_INT) :: send_rank(send_num), send_len(send_num), send_list(send_size), &
         recv_rank(recv_num), recv_len(recv_num), recv_list(recv_size)
    PRINT *, 'init_transfer', index, &
       send_num, send_size, '/', send_rank, '/', send_len, '/', &
       recv_num, recv_size, '/', recv_rank, '/', recv_len, '/' 
    CALL init_halo_transfer(send_info(index), send_rank, send_len, send_list)
    CALL init_halo_transfer(recv_info(index), recv_rank, recv_len, recv_list)
  END SUBROUTINE init_transfer

  !-------------------------------------------------------------------------------------------------!
  
  SUBROUTINE copy_in(lldata, ndata, llbuf, nbuf, cells, data, buf)
    INTEGER :: ndata, lldata, nbuf, llbuf, cells(nbuf), i
    REAL(C_DOUBLE) :: data(lldata,ndata), buf(llbuf,nbuf)
    !$OMP DO
    DO i=1,nbuf
       buf(1:lldata,i) = data(1:lldata, cells(i))
    END DO
    !$OMP END DO
  END SUBROUTINE copy_in

  SUBROUTINE copy_out(lldata, ndata, llbuf, nbuf, cells, data, buf)
    INTEGER :: ndata, lldata, nbuf, llbuf, cells(nbuf), i
    REAL(C_DOUBLE) :: data(lldata,ndata), buf(llbuf,nbuf)
    !$OMP DO SCHEDULE(STATIC)
    DO i=1,nbuf
       data(1:lldata, cells(i)) = buf(1:lldata,i) 
    END DO
    !$OMP END DO
  END SUBROUTINE copy_out

  SUBROUTINE update_halo(index, data)
    INTEGER :: index ! transfer_XXX, cf data_unstructured.F90
    REAL(C_DOUBLE) :: data(:,:)    
    TYPE(Halo_transfer), POINTER :: halo
    REAL(C_DOUBLE), POINTER :: buf(:,:)
    INTEGER :: req(send_info(index)%ranks+recv_info(index)%ranks), &
         status(MPI_STATUS_SIZE, send_info(index)%ranks+recv_info(index)%ranks)
    INTEGER :: llbuf, num, i, istart, ireq, ierr
    halo => send_info(index)
    buf => halo%buf2
    llbuf = SIZE(buf,1)
    CALL copy_in(SIZE(data,1), SIZE(data,2), llbuf, SIZE(buf,2), halo%cells, data, buf) 

    !$OMP MASTER
    ireq=0
    istart=1
    DO i = 1,halo%ranks
       num = halo%num(i)
       ireq = ireq+1
       call MPI_ISEND(buf(1,istart), llbuf*num, MPI_REAL8, halo%rank(i), &
            42, MPI_COMM_WORLD, req(ireq), ierr)
       istart = istart+num
    END DO
    !$OMP END MASTER
    halo => recv_info(index)
    buf => halo%buf2
    llbuf = SIZE(buf,1)
    !$OMP MASTER
    istart=1
    DO i = 1,halo%ranks
       num = halo%num(i)
       ireq = ireq+1
       call MPI_IRECV(buf(1,istart), llbuf*num, MPI_REAL8, halo%rank(i), &
            42, MPI_COMM_WORLD, req(ireq), ierr)
       istart = istart+num
    END DO
    CALL MPI_WAITALL(ireq, req, status, ierr)
    !$OMP END MASTER
    !$OMP BARRIER

    CALL copy_out(SIZE(data,1), SIZE(data,2), SIZE(buf,1), SIZE(buf,2), halo%cells, data, buf)
  END SUBROUTINE update_halo

  SUBROUTINE update_halo_c(index, lldata, ndata, data) BIND(C, name='dynamico_update_halo')
    INTEGER, VALUE :: index, lldata, ndata
    REAL(C_DOUBLE) :: data(lldata, ndata)
    CALL update_halo(index, data)
  END SUBROUTINE update_halo_c
  
END MODULE transfer_unstructured_mod