Changeset 953 for codes/icosagcm/trunk/src/parallel/mpipara.F90

Timestamp:

07/15/19 12:29:31 (5 years ago)

Author:

adurocher

Message:

trunk : GPU implementation with OpenACC ( merge from glcp.idris.fr )

File:

• codes/icosagcm/trunk/src/parallel/mpipara.F90 (modified) (5 diffs)

codes/icosagcm/trunk/src/parallel/mpipara.F90

@@ -14 +14 @@
   INTEGER,SAVE :: id_mpi ! id for profiling
 
+  INTEGER, SAVE :: device_id
+
   INTERFACE allocate_mpi_buffer
     MODULE PROCEDURE allocate_mpi_buffer_r2, allocate_mpi_buffer_r3,allocate_mpi_buffer_r4
@@ -46 +48 @@
   USE xios
 #endif
+  USE abort_mod
   IMPLICIT NONE
     CHARACTER(LEN=256) :: required_mode_str
@@ -75 +78 @@
       END SELECT
       
+      IF (required_mode==MPI_THREAD_SERIALIZED .OR. required_mode==MPI_THREAD_MULTIPLE) THEN
+        CALL abort_acc("mpi_threading_mode /= 'single' .AND. mpi_threading_mode /= 'funneled'")
+      ENDIF
 
       IF (required_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD required'
@@ -120 +126 @@
     ENDIF
     
+
+#ifdef _OPENACC
+    device_id = setDevice(mpi_size, mpi_rank)
+    PRINT *, 'GPU device ', device_id
+#else
+     device_id = -1
+#endif
+
   END SUBROUTINE  init_mpipara
 
@@ -233 +247 @@
   END SUBROUTINE free_mpi_buffer_r4
    
+#ifdef _OPENACC
+  FUNCTION setDevice(nprocs, myrank)
+    use iso_c_binding
+    use openacc
+    USE mpi_mod
+    implicit none
+    
+    interface 
+       function gethostid() bind(C)
+       use iso_c_binding
+       integer(C_INT) :: gethostid
+     end function gethostid
+  end interface
+  
+  integer, intent(in) :: nprocs, myrank
+  integer :: hostids(nprocs), localprocs(nprocs)
+  integer :: hostid, ierr, numdev, mydev, i, numlocal
+  integer :: setDevice
+
+  ! get the hostids so we can determine what other processes are on this node
+  hostid = gethostid()
+  call mpi_allgather(hostid,1,MPI_INTEGER,hostids,1,MPI_INTEGER, MPI_COMM_WORLD, ierr)
+
+  ! determine which processors are on this node
+  numlocal = 0
+  localprocs(:) = 0
+  do i = 1, nprocs
+     if (hostid == hostids(i)) then
+        localprocs(i) = numlocal
+        numlocal = numlocal + 1
+     end if
+  end do
+
+  ! get the number of device on this node
+  numdev = acc_get_num_devices(ACC_DEVICE_NVIDIA)
+
+  if (numdev < 1) then
+     print *, "Error: there are no devices available on this host. ABORTING", myrank
+     stop
+  end if
+
+  ! print a warning if the number of devices is less than the number of processes on this node. Having multiple processes share a devices is not recommended
+  if (numdev < numlocal) then
+     if (localprocs(myrank+1) == 1) then
+        ! print warning message only once per node
+        print *, "WARNING: the number of process is greater than the number of GPUs.", myrank
+     end if
+     mydev = mod(localprocs(myrank+1), numdev)
+  else
+     mydev = localprocs(myrank+1)
+  end if
+
+  call acc_set_device_num(mydev,ACC_DEVICE_NVIDIA)
+  call acc_init(ACC_DEVICE_NVIDIA)
+  setDevice = acc_get_device_num(ACC_DEVICE_NVIDIA)
+END FUNCTION setDevice
+
+#endif
+
+     
+     
 END MODULE mpipara