Index: codes/icosagcm/trunk/src/parallel/mpipara.F90
===================================================================
--- codes/icosagcm/trunk/src/parallel/mpipara.F90	(revision 1018)
+++ codes/icosagcm/trunk/src/parallel/mpipara.F90	(revision 1019)
@@ -14,7 +14,5 @@
   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,4 +47,5 @@
 #endif
   USE abort_mod
+  USE openacc_mod
   IMPLICIT NONE
     CHARACTER(LEN=256) :: required_mode_str
@@ -58,4 +57,6 @@
 #endif 
     
+    CALL set_openacc_device
+
     IF (using_mpi) THEN
     
@@ -127,10 +128,6 @@
     
 
-#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,64 +244,5 @@
   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
Index: codes/icosagcm/trunk/src/parallel/openacc_mod.F90
===================================================================
--- codes/icosagcm/trunk/src/parallel/openacc_mod.F90	(revision 1019)
+++ codes/icosagcm/trunk/src/parallel/openacc_mod.F90	(revision 1019)
@@ -0,0 +1,139 @@
+MODULE openacc_mod
+  
+  LOGICAL,SAVE :: openacc_initialized=.FALSE.
+  !$OMP THREADPRIVATE(openacc_initialized)
+  
+  INTEGER,SAVE :: openacc_device_id=-1
+  !$OMP THREADPRIVATE(openacc_device_id)
+
+  INTERFACE set_openacc_device
+    MODULE PROCEDURE set_device_manual, set_device_mpi
+  END INTERFACE
+  
+CONTAINS
+
+#ifdef _OPENACC
+  SUBROUTINE set_device_manual()
+    USE openacc
+    IMPLICIT NONE
+    
+    CHARACTER(len=32) :: device_id_value, slurm_local_id_value
+    INTEGER :: local_id, numdev, device_id_ierr, slurm_local_id_ierr, mydev
+    
+    IF (openacc_initialized) RETURN
+    
+    ! Use user set DEVICE_ID, then slurm set SLURM_LOCAL_ID, then fallback to default value
+    CALL get_environment_variable("DEVICE_ID", value=device_id_value, status=device_id_ierr) 
+    CALL get_environment_variable("SLURM_LOCALID", value=slurm_local_id_value, status=slurm_local_id_ierr) 
+    IF (device_id_ierr == 0) then
+       READ(device_id_value,*) local_id
+       PRINT *, "setDevice : found env variable DEVICE_ID =", local_id
+    ELSE IF (slurm_local_id_ierr == 0) then
+       READ(slurm_local_id_value,*) local_id
+       PRINT *, "setDevice : found env variable SLURM_LOCAL_ID =", local_id 
+    ELSE
+     RETURN
+    END IF
+
+    ! get the number of device on this node
+    numdev = acc_get_num_devices(ACC_DEVICE_NVIDIA)
+    WRITE( *, '("local_id=",i3," numdev=",i3)') local_id, numdev
+
+    IF (numdev < 1) then
+       PRINT *, "Error: there are no devices available on this host. ABORTING"
+       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 == local_id) then
+       ! print warning message only once per node
+       PRINT *, "WARNING: the number of process is greater than the number of GPUs."
+       mydev = mod(local_id, numdev)
+    ELSE
+       mydev = local_id
+    END IF
+  
+    CALL acc_init(ACC_DEVICE_NVIDIA)
+    CALL acc_set_device_num(mydev,ACC_DEVICE_NVIDIA)
+    openacc_device_id = acc_get_device_num(ACC_DEVICE_NVIDIA)
+    openacc_initialized=.TRUE.
+    
+  END SUBROUTINE set_device_manual
+
+#else
+  SUBROUTINE set_device_manual()
+  IMPLICIT NONE
+     
+  END SUBROUTINE set_device_manual
+#endif
+
+#ifdef _OPENACC
+  SUBROUTINE set_device_mpi(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
+
+    IF (openacc_initialized) RETURN
+
+    ! 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)
+    openacc_device_id = acc_get_device_num(ACC_DEVICE_NVIDIA)
+    openacc_initialized=.TRUE.
+
+  END SUBROUTINE set_device_mpi
+
+#else 
+
+  SUBROUTINE set_device_mpi(nprocs, myrank)
+  IMPLICIT NONE
+    INTEGER, INTENT(in) :: nprocs, myrank
+  END SUBROUTINE set_device_mpi
+
+#endif  
+
+END MODULE openacc_mod
