yomoml.F90

Go to the documentation of this file.

MODULE yomoml

!-- 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

IMPLICIT NONE

SAVE

PRIVATE

LOGICAL :: oml_debug = .false.
!$OMP THREADPRIVATE(OML_DEBUG)

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

!-- 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
!$OMP THREADPRIVATE(M_EVENT)

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

CONTAINS

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
!$ IF(PRESENT(MYLOCK))THEN
!$   CALL OMP_DESTROY_LOCK(MYLOCK)
!$ ELSE
!$   CALL OMP_DESTROY_LOCK(M_LOCK(1))
!$ ENDIF
END SUBROUTINE oml_destroy_lock

FUNCTION oml_test_event(K,MYEVENT)
LOGICAL :: OML_TEST_EVENT
INTEGER(KIND=JPIM),intent(in) :: K,MYEVENT
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
IF(PRESENT(myevent))THEN
  myevent=myevent+k
ELSE
  m_event=m_event+k
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

END MODULE yomoml