DISPATCH
omp_mod.f90
1 ! $Id: 3506c9519db919e8e3a0cf68bf1197b85363bbc9 $
2 !===============================================================================
3 MODULE omp_mod
4  USE omp_lib
5  USE io_unit_mod
6  implicit none
7  private
8  public:: omp_get_thread_num, omp_get_num_threads, omp_in_parallel
9  logical, save:: omp_trace=.false.
10  type, public:: omp_t
11  integer:: thread=0
12  integer:: ncores=1
13  integer:: nthreads=1
14  integer:: nsockets=1
15  logical:: trace=.false.
16  logical:: master=.true.
17  contains
18  procedure:: init
19  procedure, nopass:: mythread
20  procedure, nopass:: numthreads => omp_numthreads
21  procedure, nopass:: set_stacksize
22  end type
23  logical, public, save:: omp_master
24  integer, public, save:: omp_nthreads
25  integer, public, save:: omp_mythread
26  public:: omp_numthreads
27  type(omp_t), public, save:: omp
28  !$omp threadprivate (omp_master, omp, omp_mythread)
29 CONTAINS
30 
31 !===============================================================================
32 SUBROUTINE init (self)
33  class(omp_t):: self
34  !-----------------------------------------------------------------------------
35  !print*,'OMP threads:'
36  !$omp parallel
37 #if defined (_OPENMP)
38  omp_master = (omp_get_thread_num() == 0)
39  omp_mythread = omp_get_thread_num()
40  !$omp single
41  omp_nthreads = omp_get_num_threads()
42  !$omp end single
43 #else
44  omp_nthreads = 1
45  omp_master = .true.
46  omp_mythread = 0
47 #endif
48  omp%nthreads = omp_nthreads
49  omp%thread = omp_mythread
50  omp%master = omp_master
51  io_unit%master = io_unit%master .and. omp_master
52  !$omp end parallel
53 END SUBROUTINE init
54 
55 #if ! defined (_OPENMP)
56 #if ! defined (__xlc__)
57 #if ! defined (__PGI)
58 !===============================================================================
59 LOGICAL FUNCTION omp_in_parallel()
60  omp_in_parallel = .false.
61 END FUNCTION
62 #endif
63 #endif
64 #endif
65 
66 
67 
68 !===============================================================================
69 INTEGER FUNCTION mythread()
70 #if defined (_OPENMP)
71  if (omp_in_parallel()) then
72  mythread = omp_get_thread_num()
73  else
74  mythread = 0
75  end if
76 #else
77  mythread = 0
78 #endif
79 END FUNCTION
80 
81 !===============================================================================
82 INTEGER FUNCTION omp_numthreads()
83 #if defined (_OPENMP)
84  if (omp_in_parallel()) then
85  omp_numthreads = omp_get_num_threads()
86  else
87  omp_numthreads = 1
88  end if
89 #else
90  omp_numthreads = 1
91 #endif
92 END FUNCTION
93 
94 !===============================================================================
95 !> Adjust OMP_STACKSIZE according to number of passive scalars, with baseline
96 !> being 4M for MHD
97 !===============================================================================
98 SUBROUTINE set_stacksize (nv)
99 #ifdef __INTEL_COMPILER
100 #ifdef _OPENMP
101  USE omp_lib, only : kmp_set_stacksize_s, kmp_get_stacksize_s, kmp_size_t_kind
102  integer(kind=kmp_size_t_kind) :: stacksize, new_stacksize
103  real:: r
104 #endif
105 #endif
106  integer:: nv, recommended
107  character(len=16):: envvar
108  logical, save:: first_time=.true., printed=.false.
109  !-----------------------------------------------------------------------------
110  if (io_unit%do_validate) return
111  recommended = (4*1024**2*nv) / 8
112 #ifdef _OPENMP
113 #ifdef __INTEL_COMPILER
114  call getenv ('OMP_STACKSIZE', envvar)
115  if (envvar /= '' .and. io_unit%master .and. first_time) then
116  if (.not.printed) print '(1x,a)', &
117  '*************************************************************************************'
118  print '(1x,a)', &
119  '* WARNING: environment variable OMP_STACKSIZE is set, this assumes non-Intel MPI'
120  printed = .true.
121  end if
122  stacksize = kmp_get_stacksize_s()
123  new_stacksize = recommended
124  if (kind(r)==kind(1.0e0_8)) new_stacksize = new_stacksize * 2
125  if (new_stacksize > stacksize) then
126  call kmp_set_stacksize_s(new_stacksize)
127  if (io_unit%master .and. first_time) then
128  if (.not.printed) print '(1x,a)', &
129  '*************************************************************************************'
130  print '(1x,a,f5.1,a)', &
131  '* WARNING! OpenMP stacksize has been reset to ', new_stacksize/1024.**2, &
132  ' MB to avoid segfault'
133  printed = .true.
134  end if
135  else if (first_time.and.io_unit%master) then
136  print '(1x,a,f5.1,a)', 'OpenMP stacksize default:', stacksize/1024.**2, ' MB'
137  first_time = .false.
138  endif
139 #else
140  call getenv ('KMP_STACKSIZE', envvar)
141  if (envvar /= '' .and. io_unit%master .and. first_time) then
142  if (.not.printed) print '(1x,a)', &
143  '*************************************************************************************'
144  print '(1x,a)', &
145  '* WARNING: environment variable KMP_STACKSIZE is set, this assumes Intel MPI'
146  printed = .true.
147  end if
148  call getenv ('OMP_STACKSIZE', envvar)
149  if (envvar == '' .and. io_unit%master .and. first_time) then
150  print '(/,1x,a,/,1x,a,i9)', &
151  '*************************************************************************************', &
152  '* WARNING: environment variable OMP_STACKSIZE not set, recommended value =',recommended
153  printed = .true.
154  end if
155 #endif
156 #endif
157  if (printed .and. io_unit%master .and. first_time) then
158  first_time = .false.
159  print '(1x,a)', &
160  '*************************************************************************************'
161  end if
162 END SUBROUTINE set_stacksize
163 
164 !===============================================================================
165 END MODULE omp_mod