source: LMDZ6/branches/LMDZ-QUEST/libf/phylmd/rrtm/yomoml.F90 @ 3740

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