dr_hook_watch_mod.F90

Go to the documentation of this file.

MODULE dr_hook_watch_mod

USE parkind1  ,ONLY : jprd, jpim, jpib, jprm

!-- Watch point creation interface for Dr.Hook
IMPLICIT NONE
SAVE
PRIVATE

INTEGER, PUBLIC, PARAMETER :: keynone =  0
INTEGER, PUBLIC, PARAMETER :: keylog  =  1
INTEGER, PUBLIC, PARAMETER :: keychar =  2
INTEGER, PUBLIC, PARAMETER :: key_i4  =  4
INTEGER, PUBLIC, PARAMETER :: key_i8  =  8
INTEGER, PUBLIC, PARAMETER :: key_r4  = 16
INTEGER, PUBLIC, PARAMETER :: key_r8  = 32

INTERFACE dr_hook_watch
MODULE PROCEDURE &
  dr_hook_watch_character, &
  dr_hook_watch_logical_scalar, &
  dr_hook_watch_logical_vec, &
  dr_hook_watch_i4_scalar, &
  dr_hook_watch_i4_vec, &
  dr_hook_watch_i8_scalar, &
  dr_hook_watch_i8_vec, &
  dr_hook_watch_r4_scalar, &
  dr_hook_watch_r4_vec, &
  dr_hook_watch_r8_scalar, &
  dr_hook_watch_r8_vec
END INTERFACE 

PUBLIC :: dr_hook_watch
PUBLIC :: dr_hook_check_watch

CONTAINS

SUBROUTINE check_args(LLABORT, LLACTIVE, LLPRINT, LLTRBK, &
     &                IABORT, IACTIVE, IPRINT, ITRBK, IPRTKEY, &
     &                LDABORT, LDACTIVE, LDPRINT, LDTRBK)
LOGICAL, INTENT(INOUT) :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM), INTENT(OUT) :: IABORT, IACTIVE, IPRINT, ITRBK
INTEGER(KIND=JPIM), INTENT(IN) :: IPRTKEY
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
iabort = 0
llabort = .true.
IF (PRESENT(ldabort)) llabort = ldabort
IF (llabort) iabort = 1

iactive = 0
llactive = .true.
IF (PRESENT(ldactive)) llactive = ldactive
IF (llactive) iactive = 1

iprint = keynone
llprint = .true.
IF (PRESENT(ldprint)) llprint = ldprint
IF (llprint) iprint = iprtkey

itrbk = 0
lltrbk = .false.
IF (PRESENT(ldtrbk)) lltrbk = ldtrbk
IF (lltrbk) itrbk = 1
END SUBROUTINE check_args

SUBROUTINE dr_hook_watch_character(CDNAME, PTR, &
          &                        LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 1
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
CHARACTER(LEN=*), INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = len(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, keychar, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr(1:1), ibytes, iabort, iprint, len(ptr), itrbk)
END SUBROUTINE dr_hook_watch_character

SUBROUTINE dr_hook_watch_logical_scalar(CDNAME, PTR, &
          &                             LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
LOGICAL, INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = jp_bytes_per_elem
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, keylog, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr, ibytes, iabort, iprint, 1, itrbk)
END SUBROUTINE dr_hook_watch_logical_scalar

SUBROUTINE dr_hook_watch_logical_vec(CDNAME, PTR, &
          &                         LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
LOGICAL, INTENT(IN) :: PTR(:)
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = SIZE(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL c_drhook_watch(iactive, cdname, ptr(1), ibytes, iabort, iprint, SIZE(ptr), itrbk)
END SUBROUTINE dr_hook_watch_logical_vec

SUBROUTINE dr_hook_watch_i4_scalar(CDNAME, PTR, &
          &                        LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
INTEGER(KIND=JPIM), INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = jp_bytes_per_elem
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_i4, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr, ibytes, iabort, iprint, 1, itrbk)
END SUBROUTINE dr_hook_watch_i4_scalar

SUBROUTINE dr_hook_watch_i4_vec(CDNAME, PTR, &
          &                    LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
INTEGER(KIND=JPIM), INTENT(IN) :: PTR(:)
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = SIZE(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_i4, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr(1), ibytes, iabort, iprint, SIZE(ptr), itrbk)
END SUBROUTINE dr_hook_watch_i4_vec

SUBROUTINE dr_hook_watch_i8_scalar(CDNAME, PTR, &
          &                        LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
INTEGER(KIND=JPIB), INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = jp_bytes_per_elem
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_i8, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr, ibytes, iabort, iprint, 1, itrbk)
END SUBROUTINE dr_hook_watch_i8_scalar

SUBROUTINE dr_hook_watch_i8_vec(CDNAME, PTR, &
          &                    LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
INTEGER(KIND=JPIB), INTENT(IN) :: PTR(:)
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = SIZE(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_i8, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr(1), ibytes, iabort, iprint, SIZE(ptr), itrbk)
END SUBROUTINE dr_hook_watch_i8_vec

SUBROUTINE dr_hook_watch_r4_scalar(CDNAME, PTR, &
          &                        LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
REAL(KIND=JPRM), INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = jp_bytes_per_elem
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_r4, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr, ibytes, iabort, iprint, 1, itrbk)
END SUBROUTINE dr_hook_watch_r4_scalar

SUBROUTINE dr_hook_watch_r4_vec(CDNAME, PTR, &
          &                    LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
REAL(KIND=JPRM), INTENT(IN) :: PTR(:)
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = SIZE(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_r4, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr(1), ibytes, iabort, iprint, SIZE(ptr), itrbk)
END SUBROUTINE dr_hook_watch_r4_vec

SUBROUTINE dr_hook_watch_r8_scalar(CDNAME, PTR, &
          &                        LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
REAL(KIND=JPRD), INTENT(IN) :: PTR
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = jp_bytes_per_elem
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_r8, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr, ibytes, iabort, iprint, 1, itrbk)
END SUBROUTINE dr_hook_watch_r8_scalar

SUBROUTINE dr_hook_watch_r8_vec(CDNAME, PTR, &
          &                    LDABORT, LDACTIVE, LDPRINT, LDTRBK)
INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8
CHARACTER(LEN=*), INTENT(IN) :: CDNAME
REAL(KIND=JPRD), INTENT(IN) :: PTR(:)
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK
LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK
INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK
ibytes = SIZE(ptr) * jp_bytes_per_elem
IF (ibytes <= 0) RETURN
CALL check_args(llabort, llactive, llprint, lltrbk, &
     &          iabort, iactive, iprint, itrbk, key_r8, &
     &          ldabort, ldactive, ldprint, ldtrbk)
CALL c_drhook_watch(iactive, cdname, ptr(1), ibytes, iabort, iprint, SIZE(ptr), itrbk)
END SUBROUTINE dr_hook_watch_r8_vec

SUBROUTINE dr_hook_check_watch(CDWHERE, LDABORT)
CHARACTER(LEN=*), INTENT(IN) :: CDWHERE
LOGICAL, INTENT(IN), OPTIONAL :: LDABORT
LOGICAL :: LLABORT
INTEGER(KIND=JPIM) :: IABORT
iabort = 0
llabort = .false.
IF (PRESENT(ldabort)) llabort = ldabort
IF (llabort) iabort = 1
CALL c_drhook_check_watch(cdwhere, iabort)
END SUBROUTINE dr_hook_check_watch

END MODULE dr_hook_watch_mod