mirror of
https://github.com/OpenMP/Examples.git
synced 2025-04-07 23:22:11 +01:00
64 lines
1.6 KiB
Fortran
64 lines
1.6 KiB
Fortran
! @@name: nestable_lock.1f
|
|
! @@type: F-fixed
|
|
! @@compilable: yes
|
|
! @@linkable: no
|
|
! @@expect: success
|
|
MODULE DATA
|
|
USE OMP_LIB, ONLY: OMP_NEST_LOCK_KIND
|
|
TYPE LOCKED_PAIR
|
|
INTEGER A
|
|
INTEGER B
|
|
INTEGER (OMP_NEST_LOCK_KIND) LCK
|
|
END TYPE
|
|
END MODULE DATA
|
|
|
|
SUBROUTINE INCR_A(P, A)
|
|
! called only from INCR_PAIR, no need to lock
|
|
USE DATA
|
|
TYPE(LOCKED_PAIR) :: P
|
|
INTEGER A
|
|
P%A = P%A + A
|
|
END SUBROUTINE INCR_A
|
|
|
|
SUBROUTINE INCR_B(P, B)
|
|
! called from both INCR_PAIR and elsewhere,
|
|
! so we need a nestable lock
|
|
USE OMP_LIB ! or INCLUDE "omp_lib.h"
|
|
USE DATA
|
|
TYPE(LOCKED_PAIR) :: P
|
|
INTEGER B
|
|
CALL OMP_SET_NEST_LOCK(P%LCK)
|
|
P%B = P%B + B
|
|
CALL OMP_UNSET_NEST_LOCK(P%LCK)
|
|
END SUBROUTINE INCR_B
|
|
|
|
SUBROUTINE INCR_PAIR(P, A, B)
|
|
USE OMP_LIB ! or INCLUDE "omp_lib.h"
|
|
USE DATA
|
|
TYPE(LOCKED_PAIR) :: P
|
|
INTEGER A
|
|
INTEGER B
|
|
|
|
CALL OMP_SET_NEST_LOCK(P%LCK)
|
|
CALL INCR_A(P, A)
|
|
CALL INCR_B(P, B)
|
|
CALL OMP_UNSET_NEST_LOCK(P%LCK)
|
|
END SUBROUTINE INCR_PAIR
|
|
|
|
SUBROUTINE NESTLOCK(P)
|
|
USE OMP_LIB ! or INCLUDE "omp_lib.h"
|
|
USE DATA
|
|
TYPE(LOCKED_PAIR) :: P
|
|
INTEGER WORK1, WORK2, WORK3
|
|
EXTERNAL WORK1, WORK2, WORK3
|
|
|
|
!$OMP PARALLEL SECTIONS
|
|
|
|
!$OMP SECTION
|
|
CALL INCR_PAIR(P, WORK1(), WORK2())
|
|
!$OMP SECTION
|
|
CALL INCR_B(P, WORK3())
|
|
!$OMP END PARALLEL SECTIONS
|
|
|
|
END SUBROUTINE NESTLOCK
|