oml_mod.F90

Go to the documentation of this file.

MODULE oml_mod

!-- the following system specific omp_lib-module is not always available (e.g. pgf90)
!! use omp_lib

USE parkind1  ,ONLY : jpim, jpib

!**SS/18-Feb-2005
!--Dr.Hook references removed, because these locks may also be
!  called from within drhook.c itself !! 
!--Also, there could be considerable & unjustified overhead
!  when using Dr.Hook in such a low level

!**SS/15-Dec-2005
!--The size of lock-variables are now OMP_LOCK_KIND as of in OMP_LIB,
!  and OMP_LOCK_KIND is aliased to OML_LOCK_KIND
!  OMP_LOCK_KIND is usually 4 in 32-bit addressing mode
!                           8 in 64-bit addressing mode
!--M_OML_LOCK changed to M_EVENT and kept as 32-bit int
!--OML_FUNCT changed to OML_TEST_EVENT
!--M_LOCK initialized to -1
!--M_EVENT initialized to 0
!--Added intent(s)
!--Support for omp_lib (but not always available)
!--Locks can now also be set/unset OUTSIDE the parallel regions
!--Added routine OML_TEST_LOCK (attempts to set lock, but if *un*successful, does NOT  block)
!--Buffer-zone for M_LOCK; now a vector of 2 elements in case problems/inconsistencies with OMP_LOCK_KIND 4/8

!**SS/22-Feb-2006
!--Locking routines are doing nothing unless OMP_GET_MAX_THREADS() > 1
!  This is to avoid unacceptable deadlocks/timeouts with signal handlers when
!  the only thread receives signal while inside locked region
!--Affected routines: OML_TEST_LOCK()  --> always receives .TRUE.
!                     OML_SET_LOCK()   --> sets nothing
!                     OML_UNSET_LOCK() --> unsets nothing
!                     OML_INIT_LOCK()  --> inits nothing

!**SS/11-Sep-2006
!--Added OML_DEBUG feature

!**REK/18-Jul-2007
!--Protected OML_DESTROY_LOCK

!**REK/07-Sep-2007
!--Add OMP FLUSH feature

!**SS/05-Dec-2007
!--Added routine OML_NUM_THREADS([optional_new_number_of_threads])
! 1) To adjust [reduce] the number of threads working in concert
!    Accepts only # of threads between 1 and the max # of threads (i.e. from export OMP_NUM_THREADS=<value>)
! 2) Returns the previous active number of threads
! 3) Can be called from outside the OpenMP-parallel region only

!**SS/14-Dec-2007
!--The routine OML_NUM_THREADS() now also accepts character string (= environment variable)
!  as the sole argumentoz
!--You could now set effective number of threads (<= $OMP_NUM_THREADS) to the value of
!  particular environment variable; f.ex.:
!  export OML_MSGPASS_OBSDATA_READ=8 and call to OML_NUM_THREADS('OML_MSGPASS_OBSDATA_READ')
!  would set the effective no. of threads to (max) 8 when reading obs. wiz msgpass_obsdata

!**SS/09-May-2008
!-- OML_NUM_THREADS() did not work as expected since I misinterpreted the meaning of 
!   the OpenMP-function OMP_NUM_THREADS()
!-- With two PRIVATE [to this module] variables the bug will get sorted out
!   + a new routine OML_INIT() was added (to be called from MPL_INIT or so)

!**FV/27-May-2009
!-- OML_GET_NUM_THREADS()

IMPLICIT NONE

SAVE

PRIVATE

LOGICAL :: oml_debug = .false.

INTERFACE oml_num_threads
MODULE PROCEDURE &
     & oml_num_threads_int, &
     & oml_num_threads_str
END INTERFACE

PUBLIC oml_wait_event, oml_set_event, oml_incr_event, &
   &   oml_my_thread,  oml_max_threads , oml_omp, &
   &   oml_in_parallel, oml_test_event, &
   &   oml_unset_lock, oml_init_lock, oml_set_lock, oml_destroy_lock, &
   &   oml_lock_kind, oml_test_lock, oml_debug, oml_num_threads, &
   &   oml_init, oml_get_num_threads

!-- The following should normally be 4 in 32-bit addressing mode
!                                    8 in 64-bit addressing mode
! Since system specific omp_lib-module is not always available (e.g. pgf90)
! we hardcode OML_LOCK_KIND to JPIB (usually 8) for now
!!INTEGER(KIND=JPIM), PARAMETER :: OML_LOCK_KIND = OMP_LOCK_KIND
INTEGER(KIND=JPIM), PARAMETER :: oml_lock_kind = jpib

!-- Note: Still JPIM !!
INTEGER(KIND=JPIM) :: m_event = 0

!-- Note: OML_LOCK_KIND, not JPIM !!
INTEGER(KIND=OML_LOCK_KIND) :: m_lock(2) = (/-1, -1/)

!-- The two PRIVATE [to this module] variables
INTEGER(KIND=JPIM) :: n_oml_max_threads = -1

CONTAINS

SUBROUTINE oml_init()
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
IF (n_oml_max_threads == -1) THEN
   n_oml_max_threads = 1
!$ N_OML_MAX_THREADS = OMP_GET_MAX_THREADS()
ENDIF
END SUBROUTINE oml_init

FUNCTION oml_omp()
LOGICAL :: OML_OMP
oml_omp=.false.
!$ OML_OMP=.TRUE.
END FUNCTION oml_omp

FUNCTION oml_in_parallel()
LOGICAL :: OML_IN_PARALLEL
!$ LOGICAL :: OMP_IN_PARALLEL
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
oml_in_parallel=.false.
!$ OML_IN_PARALLEL=((OMP_GET_MAX_THREADS() > 1).AND.OMP_IN_PARALLEL())
END FUNCTION oml_in_parallel

FUNCTION oml_test_lock(MYLOCK)
INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK
LOGICAL :: OML_TEST_LOCK
!$ LOGICAL :: OMP_TEST_LOCK
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
oml_test_lock = .true.
!$ IF(OMP_GET_MAX_THREADS() > 1) THEN
!$   IF(PRESENT(MYLOCK))THEN
!$     OML_TEST_LOCK = OMP_TEST_LOCK(MYLOCK)
!$   ELSE
!$     OML_TEST_LOCK = OMP_TEST_LOCK(M_LOCK(1))
!$   ENDIF
!$ ENDIF
END FUNCTION oml_test_lock

SUBROUTINE oml_unset_lock(MYLOCK)
INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
!$ IF(OMP_GET_MAX_THREADS() > 1) THEN
!$   IF(PRESENT(MYLOCK))THEN
!$     CALL OMP_UNSET_LOCK(MYLOCK)
!$   ELSE
!$     CALL OMP_UNSET_LOCK(M_LOCK(1))
!$   ENDIF
!$ ENDIF
END SUBROUTINE oml_unset_lock

SUBROUTINE oml_set_lock(MYLOCK)
INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
!$ IF(OMP_GET_MAX_THREADS() > 1) THEN
!$   IF(PRESENT(MYLOCK))THEN
!$     CALL OMP_SET_LOCK(MYLOCK)
!$   ELSE
!$     CALL OMP_SET_LOCK(M_LOCK(1))
!$   ENDIF
!$ ENDIF
END SUBROUTINE oml_set_lock

SUBROUTINE oml_init_lock(MYLOCK)
INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
!$ IF(OMP_GET_MAX_THREADS() > 1) THEN
!$   IF(PRESENT(MYLOCK))THEN
!$     CALL OMP_INIT_LOCK(MYLOCK)
!$   ELSE
!$     CALL OMP_INIT_LOCK(M_LOCK(1))
!$   ENDIF
!$ ENDIF
END SUBROUTINE oml_init_lock

SUBROUTINE oml_destroy_lock(MYLOCK)
INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
!$ IF(OMP_GET_MAX_THREADS() > 1) THEN
!$   IF(PRESENT(MYLOCK))THEN
!$     CALL OMP_DESTROY_LOCK(MYLOCK)
!$   ELSE
!$     CALL OMP_DESTROY_LOCK(M_LOCK(1))
!$   ENDIF
!$ ENDIF
END SUBROUTINE oml_destroy_lock

FUNCTION oml_test_event(K,MYEVENT)
LOGICAL :: OML_TEST_EVENT
INTEGER(KIND=JPIM),INTENT(IN) :: K,MYEVENT
#ifndef RS6K
!$OMP FLUSH
#endif
IF(k.EQ.myevent) THEN
 oml_test_event =.true.
ELSE
 oml_test_event=.false.
ENDIF
END FUNCTION oml_test_event

SUBROUTINE oml_wait_event(K,MYEVENT)
INTEGER(KIND=JPIM),INTENT(IN) :: K
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: MYEVENT
IF(PRESENT(myevent))THEN
  DO
    IF(oml_test_event(k,myevent)) EXIT
  ENDDO
ELSE
  DO
    IF(oml_test_event(k,m_event)) EXIT
  ENDDO
ENDIF
END SUBROUTINE oml_wait_event

SUBROUTINE oml_set_event(K,MYEVENT)
INTEGER(KIND=JPIM),INTENT(IN) :: K
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: MYEVENT
IF(PRESENT(myevent))THEN
  myevent=k
ELSE
  m_event=k
ENDIF
END SUBROUTINE oml_set_event

SUBROUTINE oml_incr_event(K,MYEVENT)
INTEGER(KIND=JPIM) :: K
INTEGER(KIND=JPIM),INTENT(INOUT),OPTIONAL :: MYEVENT
!$OMP FLUSH
IF(PRESENT(myevent))THEN
!$OMP ATOMIC
  myevent=myevent+k
ELSE
!$OMP ATOMIC
  m_event=m_event+k
ENDIF
#ifndef RS6K
!$OMP FLUSH
#endif
END SUBROUTINE oml_incr_event

FUNCTION oml_my_thread()
INTEGER(KIND=JPIM) :: OML_MY_THREAD
!$ INTEGER(KIND=JPIM) OMP_GET_THREAD_NUM
oml_my_thread = 1
!$ OML_MY_THREAD = OMP_GET_THREAD_NUM() + 1
END FUNCTION oml_my_thread

FUNCTION oml_max_threads()
INTEGER(KIND=JPIM) :: OML_MAX_THREADS
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
oml_max_threads = 1
!$ OML_MAX_THREADS = OMP_GET_MAX_THREADS()
END FUNCTION oml_max_threads

FUNCTION oml_get_num_threads()
INTEGER(KIND=JPIM) :: OML_GET_NUM_THREADS
!$ INTEGER(KIND=JPIM) OMP_GET_NUM_THREADS
oml_get_num_threads = 1
!$ OML_GET_NUM_THREADS = OMP_GET_NUM_THREADS()
END FUNCTION oml_get_num_threads

FUNCTION oml_num_threads_int(KOMP_SET_THREADS)
INTEGER(KIND=JPIM) :: OML_NUM_THREADS_INT
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KOMP_SET_THREADS
!$ LOGICAL :: OMP_IN_PARALLEL
!$ INTEGER(KIND=JPIM) OMP_GET_MAX_THREADS
oml_num_threads_int = 1
!$ OML_NUM_THREADS_INT = OMP_GET_MAX_THREADS()
!$ IF (PRESENT(KOMP_SET_THREADS)) THEN
!$   IF (KOMP_SET_THREADS >= 1 .AND. KOMP_SET_THREADS <= N_OML_MAX_THREADS) THEN
!- This is the absolute max no. of threads available --> ^^^^^^^^^^^^^^^^^ <--
!$     IF (.NOT.OMP_IN_PARALLEL()) THEN ! Change only if called from OUTSIDE the OpenMP-parallel region
!$       CALL OMP_SET_NUM_THREADS(KOMP_SET_THREADS)
!$     ENDIF
!$   ENDIF
!$ ENDIF
END FUNCTION oml_num_threads_int

FUNCTION oml_num_threads_str(CD_ENV)
INTEGER(KIND=JPIM) :: OML_NUM_THREADS_STR
CHARACTER(LEN=*),INTENT(IN) :: CD_ENV
!$ character(len=20) CLvalue
!$ INTEGER(KIND=JPIM) :: itmp
oml_num_threads_str = 1
!$ OML_NUM_THREADS_STR = OML_NUM_THREADS_INT()
!$ IF (LEN(CD_ENV) > 0) THEN
!$   CALL GET_ENVIRONMENT_VARIABLE(CD_ENV,CLvalue)
!$   IF (CLvalue /= ' ') THEN
!$     READ(CLvalue,'(i20)',end=99,err=99) itmp
!$     OML_NUM_THREADS_STR = OML_NUM_THREADS_INT(itmp)
!$   ENDIF
!$ 99 continue
!$ ENDIF
END FUNCTION oml_num_threads_str

END MODULE oml_mod