comin_callback.F90

Go to the documentation of this file.

 
!
!  @authors 08/2021 :: ICON Community Interface  <comin@icon-model.org>
!
!  SPDX-License-Identifier: BSD-3-Clause
!
!  See LICENSES for license information.
!  Where software is supplied by third parties, it is indicated in the
!  headers of the routines.
!
MODULE comin_callback
 
  USE iso_c_binding, ONLY: c_int, c_char, c_ptr, c_loc, c_f_pointer
  USE comin_setup_constants,      ONLY: ep_destructor,             &
       &                                   domain_undefined, comin_flag_device, comin_flag_write, comin_flag_read, &
       &                                   comin_flag_sync_halo, comin_zaxis_2d, comin_zaxis_3d
  USE comin_state,                ONLY: state
  USE comin_errhandler,           ONLY: comin_message, comin_error_set
  USE comin_errhandler_constants, ONLY: comin_error_callback_register_outside_primaryconstructor, &
       &                                comin_error_callback_complete, comin_error_callback_ep_id_unknown, &
       &                                comin_error_var_sync_halo_not_supported_zaxis
  USE comin_callback_types,       ONLY: comin_callback_routine, t_comin_callback_element
  USE comin_variable_types,       ONLY: t_comin_var_context_item, comin_var_ptr_init
  USE comin_setup_constants,      ONLY: ep_name
  USE comin_c_utils,              ONLY: convert_f_string
  USE comin_ftnlist_ifc,          ONLY: comin_ftnlist_push_back, comin_ftnlist_is_end, comin_ftnlist_iterator_begin, &
    &                                   comin_ftnlist_iterator_delete, comin_ftnlist_iterator_next, &
    &                                   comin_ftnlist_iterator_value, comin_ftnlist_delete
 
  IMPLICIT NONE
 
  PRIVATE
 
  PUBLIC :: comin_callback_register, comin_callback_context_call, comin_callback_complete
  PUBLIC :: comin_callback_get_ep_name
 
#include "comin_global.inc"
 
CONTAINS
 
  SUBROUTINE comin_callback_register(entry_point_id, fct_ptr) &
    &  BIND(C)
    INTEGER(kind=C_INT), INTENT(IN), VALUE        :: entry_point_id
    PROCEDURE(comin_callback_routine) :: fct_ptr
    !
    CHARACTER(LEN=:), ALLOCATABLE :: ep_name
    TYPE(t_comin_callback_element), POINTER :: item
 
    IF (state%l_primary_done) THEN
      CALL comin_error_set(comin_error_callback_register_outside_primaryconstructor)
      RETURN
    ENDIF
 
    ALLOCATE(item)
    item = t_comin_callback_element(entry_point_id = entry_point_id, &
      &                             plugin_info    = state%current_plugin, &
      &                             comin_callback = fct_ptr)
    CALL comin_ftnlist_push_back(state%comin_callback_list, c_loc(item))
 
    CALL comin_callback_get_ep_name(entry_point_id, ep_name)
    CALL comin_message("    registration for '"//ep_name//"' (ep: "//&
         &int2string(entry_point_id,'(i0)')//") associated for 3rd party plugin "//&
         &trim(state%current_plugin%name)//" successful.", 12)
  END SUBROUTINE comin_callback_register
 
  SUBROUTINE comin_callback_complete()
    ! local
    INTEGER :: ep_loc, tp_loc
    CHARACTER(LEN=:), ALLOCATABLE :: ep_name
    INTEGER                       :: status
    TYPE(c_ptr)                   :: it, cptr
    TYPE(t_comin_callback_element), POINTER :: var_list_element
 
    CALL comin_message("     Complete primary constructors", 0)
 
    ALLOCATE(state%comin_callback_context(1:ep_destructor,1:state%num_plugins), stat=status)
    IF (status /= 0) THEN
      CALL comin_error_set(comin_error_callback_complete); RETURN
    END IF
    ALLOCATE(state%comin_callback_order(1:ep_destructor,1:state%num_plugins), stat=status)
    IF (status /= 0) THEN
      CALL comin_error_set(comin_error_callback_complete); RETURN
    END IF
    state%comin_callback_order = 0
    CALL comin_ftnlist_iterator_begin(state%comin_callback_list, it)
    DO WHILE (.not. comin_ftnlist_is_end(state%comin_callback_list,it))
      CALL comin_ftnlist_iterator_value(it, cptr)
      CALL c_f_pointer(cptr, var_list_element)
 
      ep_loc = var_list_element%entry_point_id
      tp_loc = var_list_element%plugin_info%id
 
      associate(callback_context => state%comin_callback_context(ep_loc, tp_loc))
        IF (.NOT. ASSOCIATED(callback_context%vl)) THEN
          ALLOCATE(callback_context%vl)
        ELSE
          CALL comin_callback_get_ep_name(ep_loc, ep_name)
          CALL comin_message("     WARNING:: Overwrite callback for plugin '"//&
               &state%current_plugin%name//"' at entry point '"//ep_name//"' (ep: "//&
               &int2string(ep_loc,'(i0)')//")", 0)
        END IF
        callback_context%vl = t_comin_callback_element(                &
          &              entry_point_id = ep_loc,                      &
          &              plugin_info    = var_list_element%plugin_info, &
          &              comin_callback = var_list_element%comin_callback)
        state%comin_callback_order(ep_loc, tp_loc) = tp_loc
      END associate
      CALL comin_ftnlist_iterator_next(it)
    END DO
    CALL comin_ftnlist_iterator_delete(it)
    call comin_ftnlist_iterator_begin(state%comin_callback_list, it)
    do while (.not. comin_ftnlist_is_end(state%comin_callback_list,it))
      call comin_ftnlist_iterator_value(it, cptr)
      call c_f_pointer(cptr, var_list_element)
      deallocate(var_list_element)
      call comin_ftnlist_iterator_next(it)
    end do
    call comin_ftnlist_iterator_delete(it)
    call comin_ftnlist_delete(state%comin_callback_list)
 
    ! Note: re-ordering based on namelist settings will be implemented
    !       in a later version of ComIn
    !       current default: order as at registration
 
    ! Note:
    ! the adapter library checks for duplicates and exclusiveness of requested
    ! variables and potentially aborts directly in comin_var_request_add
    ! therefore no further check before secondary constructor required
 
  END SUBROUTINE comin_callback_complete
 
  RECURSIVE SUBROUTINE comin_callback_context_call(entry_point_id, domain_id, lacc)
    INTEGER, INTENT(IN)            :: entry_point_id
    INTEGER, INTENT(IN)            :: domain_id
    LOGICAL, INTENT(IN)            :: lacc
    TYPE(t_comin_callback_element), POINTER :: cl
    !PROCEDURE(comin_callback_routine), POINTER :: comin_callback_context
    INTEGER   :: thirdpi, loci
    LOGICAL :: lcallbacks_exist
    CHARACTER(LEN=:), ALLOCATABLE :: ep_name
 
    ! We cant call callbacks before the primary constructors are done
    ! and comin_callback_complete was called. (e.g. EP_FINISH)
    if(.NOT. state%l_primary_done) RETURN
 
    CALL comin_callback_get_ep_name(entry_point_id, ep_name)
    CALL comin_message("     CONTEXT " // ep_name, 12)
 
    lcallbacks_exist = SIZE(state%comin_callback_order,2) > 0
    IF (lcallbacks_exist)  lcallbacks_exist = (sum(state%comin_callback_order(entry_point_id,:)) /= 0)
 
    IF (lcallbacks_exist) THEN
      DO thirdpi=1,state%num_plugins
        loci = state%comin_callback_order(entry_point_id, thirdpi)
        NULLIFY(cl)
        IF (loci > 0) cl => state%comin_callback_context(entry_point_id,loci)%vl
        IF (ASSOCIATED(cl)) THEN
          CALL comin_message("     current ep '"//ep_name//"' (ep: "//&
               &int2string(cl%entry_point_id,'(i0)')//") for library: "//cl%plugin_info%name, 0)
          ! undefine domain id for the call of the ComIn destructor
          IF (entry_point_id == ep_destructor) state%current_domain_id = domain_undefined
          IF (.NOT. lacc) CALL check_var_no_device(entry_point_id, thirdpi)
          IF (lacc) CALL sync_vars_for_device(entry_point_id, thirdpi, comin_flag_read)
          CALL sync_vars_for_halo_region(entry_point_id, thirdpi, comin_flag_read)
          ! set current plugin
          state%current_plugin => cl%plugin_info
          ! set current entry point
          state%current_ep = entry_point_id
          ! set current domain id
          state%current_domain_id = domain_id
          CALL cl%comin_callback
          NULLIFY(state%current_plugin)
          CALL sync_vars_for_halo_region(entry_point_id, thirdpi, comin_flag_write)
          IF (lacc) CALL sync_vars_for_device(entry_point_id, thirdpi, comin_flag_write)
        ELSE
          CALL comin_message("      entry point '"//ep_name//"' (ep: "//&
               &int2string(entry_point_id,'(i0)')//") not associated", 12)
        END IF
      ENDDO
    ELSE
      CALL comin_message("     no calls associated with entry point '"//&
           &ep_name//"' (ep: "//int2string(entry_point_id,'(i0)')//").", 12)
    END IF
    DEALLOCATE(ep_name)
  END SUBROUTINE comin_callback_context_call
 
  SUBROUTINE sync_vars_for_device(ep, plugin_id, rw_flag)
    INTEGER, INTENT(IN) :: ep
    INTEGER, INTENT(IN) :: plugin_id
    INTEGER, INTENT(IN) :: rw_flag
    ! locals
    TYPE(c_ptr) :: it, cptr
    TYPE(t_comin_var_context_item), POINTER :: item
 
    CALL comin_ftnlist_iterator_begin(state%comin_var_list_context(ep , plugin_id)%var_list, it)
    DO WHILE (.not. comin_ftnlist_is_end(state%comin_var_list_context(ep , plugin_id)%var_list,it))
 
      CALL comin_ftnlist_iterator_value(it, cptr)
      CALL c_f_pointer(cptr, item)
 
      IF (iand(item%access_flag, comin_flag_device) == 0 .AND. &
 &        iand(item%access_flag, rw_flag) /= 0) THEN
        CALL state%sync_device_mem(comin_var_ptr_init(item%var_item), rw_flag == comin_flag_write)
      END IF
      CALL comin_ftnlist_iterator_next(it)
    END DO
    CALL comin_ftnlist_iterator_delete(it)
  END SUBROUTINE sync_vars_for_device
 
  SUBROUTINE check_var_no_device(ep, plugin_id)
    INTEGER, INTENT(IN) :: ep
    INTEGER, INTENT(IN) :: plugin_id
    ! locals
    TYPE(c_ptr) :: it, cptr
    TYPE(t_comin_var_context_item), POINTER :: item
    CHARACTER(LEN=:), ALLOCATABLE :: ep_name
 
    CALL comin_callback_get_ep_name(ep, ep_name)
 
    CALL comin_ftnlist_iterator_begin(state%comin_var_list_context(ep , plugin_id)%var_list, it)
    DO WHILE (.not. comin_ftnlist_is_end(state%comin_var_list_context(ep , plugin_id)%var_list,it))
      CALL comin_ftnlist_iterator_value(it, cptr)
      CALL c_f_pointer(cptr, item)
 
      IF (iand(item%access_flag, comin_flag_device) /= 0) THEN
        CALL comin_message("WARNING: Device access at a non-ported entrypoint (" // &
             &             ep_name // &
             &             ") requested.", 1)
      END IF
      CALL comin_ftnlist_iterator_next(it)
    END DO
    CALL comin_ftnlist_iterator_delete(it)
  END SUBROUTINE check_var_no_device
 
  SUBROUTINE sync_vars_for_halo_region(ep, plugin_id, rw_flag)
    INTEGER, INTENT(IN) :: ep
    INTEGER, INTENT(IN) :: plugin_id
    INTEGER, INTENT(IN) :: rw_flag
    !locals
    INTEGER             :: halo_sync_mode
    TYPE(c_ptr) :: it, cptr
    TYPE(t_comin_var_context_item), POINTER :: item
    CALL comin_ftnlist_iterator_begin(state%comin_var_list_context(ep , plugin_id)%var_list, it)
    DO WHILE (.not. comin_ftnlist_is_end(state%comin_var_list_context(ep , plugin_id)%var_list,it))
      CALL comin_ftnlist_iterator_value(it, cptr)
      CALL c_f_pointer(cptr, item)
      IF (iand(item%access_flag, comin_flag_sync_halo) /= 0 .AND. &
           &        iand(item%access_flag, rw_flag) /= 0) THEN
        CALL determine_halo_sync_mode(item, halo_sync_mode)
        CALL state%sync_halo(comin_var_ptr_init(item%var_item), halo_sync_mode)
      END IF
      CALL comin_ftnlist_iterator_next(it)
    END DO
    CALL comin_ftnlist_iterator_delete(it)
  END SUBROUTINE sync_vars_for_halo_region
 
  SUBROUTINE determine_halo_sync_mode(item, halo_sync_mode)
    TYPE(t_comin_var_context_item), POINTER, INTENT(IN) :: item
    INTEGER, INTENT(OUT)                        :: halo_sync_mode
    !locals
    CHARACTER(LEN=20)                           :: metadata_key
    INTEGER                                     :: val
    metadata_key = 'zaxis_id'
    CALL item%var_item%metadata%get(metadata_key, val)
    IF (val == comin_zaxis_2d) THEN
      halo_sync_mode = comin_zaxis_2d
    ELSE IF (val == comin_zaxis_3d) THEN
      halo_sync_mode = comin_zaxis_3d
    ELSE
      CALL comin_error_set(comin_error_var_sync_halo_not_supported_zaxis); RETURN
    END IF
  END SUBROUTINE determine_halo_sync_mode
  ! returns integer n as a string (needed in printing messages)
  FUNCTION int2string(n, opt_fmt)
    CHARACTER(:), ALLOCATABLE :: int2string ! result
    CHARACTER(len=128) :: res
    INTEGER, INTENT(in) :: n
    CHARACTER(len=*), INTENT(in), OPTIONAL :: opt_fmt
    !
    CHARACTER(len=128) :: fmt
 
    IF (PRESENT(opt_fmt)) THEN
      fmt = opt_fmt
    ELSE
      fmt = '(i0)'
    END IF
    WRITE(res,fmt) n
    res = adjustl(res)
    int2string = trim(res)
  END FUNCTION int2string
 
  SUBROUTINE comin_callback_get_ep_name( iep, out_ep_name )
    INTEGER, INTENT(IN)  :: iep
    CHARACTER(LEN=:), ALLOCATABLE, INTENT(OUT) :: out_ep_name
 
    IF ((iep < 0) .OR. (iep > ep_destructor)) THEN
      out_ep_name = "UNKNOWN"
      CALL comin_error_set(comin_error_callback_ep_id_unknown); RETURN
    ELSE
      out_ep_name = trim(ep_name(iep))
    END IF
  END SUBROUTINE comin_callback_get_ep_name
 
  !
  SUBROUTINE comin_callback_get_ep_name_c( iep, out_ep_name) &
    &     BIND(C, name="comin_callback_get_ep_name")
    INTEGER(c_int), VALUE, INTENT(IN)  :: iep
    CHARACTER(len=1, kind=c_char),DIMENSION(COMIN_MAX_LEN_EP_NAME+1)  :: out_ep_name
    !
    CHARACTER(LEN=:), ALLOCATABLE :: ep_name
 
    CALL comin_callback_get_ep_name(iep, ep_name)
    CALL convert_f_string(ep_name, out_ep_name)
  END SUBROUTINE comin_callback_get_ep_name_c
 
END MODULE comin_callback