Changeset 1019 for codes/icosagcm/trunk/src

Timestamp:

03/09/20 14:27:24 (4 years ago)

Author:

ymipsl

Message:

On Jean-zay supercomputer with omnipath network, OpenACC need to be initialized before the MPI initialization wich can be a problem to select GPU device. This is a specifc hook for Jean Zay using slurm or reading an environment variable to retrive the local rank of the process.

YM

Location:

codes/icosagcm/trunk/src/parallel

Files:

• mpipara.F90 (modified) (5 diffs)
• openacc_mod.F90 (added)

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

@@ -14 +14 @@
   INTEGER,SAVE :: id_mpi ! id for profiling
 
-  INTEGER, SAVE :: device_id
-
-  INTERFACE allocate_mpi_buffer
+   INTERFACE allocate_mpi_buffer
     MODULE PROCEDURE allocate_mpi_buffer_r2, allocate_mpi_buffer_r3,allocate_mpi_buffer_r4
   END INTERFACE allocate_mpi_buffer
@@ -49 +47 @@
 #endif
   USE abort_mod
+  USE openacc_mod
   IMPLICIT NONE
     CHARACTER(LEN=256) :: required_mode_str
@@ -58 +57 @@
 #endif 
     
+    CALL set_openacc_device
+
     IF (using_mpi) THEN
     
@@ -127 +128 @@
     
 
-#ifdef _OPENACC
-    device_id = setDevice(mpi_size, mpi_rank)
-    PRINT *, 'GPU device ', device_id
-#else
-     device_id = -1
-#endif
+    CALL set_openacc_device(mpi_size, mpi_rank)
+    PRINT *, 'GPU device ', openacc_device_id
 
   END SUBROUTINE  init_mpipara
@@ -247 +244 @@
   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