comin_setup.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_setup
 
  USE comin_callback,        ONLY: comin_callback_complete
  USE comin_variable,        ONLY: comin_var_complete
  USE comin_setup_constants, ONLY: wp
  USE comin_setup_utils,     ONLY: t_comin_setup_version_info, comin_setup_get_version, &
       &                           comin_setup_version_compatible
  USE comin_state,           ONLY: t_comin_state, state
  USE comin_c_utils,         ONLY: convert_c_string, convert_f_string
  USE comin_parallel,        ONLY: comin_parallel_free_mpi_comms
  USE comin_plugin_types,    ONLY: t_comin_plugin_description,        &
    &                              t_comin_plugin_info
  USE comin_errhandler_constants, ONLY: comin_error_setup_errhandler_not_set,               &
    &                                   comin_error_setup_precision_test_failed,            &
    &                                   comin_error_setup_finalize,                         &
    &                                   comin_error_setup_errhandler_not_associated,        &
    &                                   comin_error_descrdata_set_fct_glb2loc,              &
    &                                   comin_error_plugin_init_comin_version,              &
    &                                   comin_error_plugin_init_precision,                  &
    &                                   comin_error_plugin_init_state_initialized,          &
    &                                   comin_error_setup_comin_already_initialized
  USE comin_errhandler,      ONLY: comin_message, comin_plugin_finish, comin_error_set
  USE comin_errhandler_types, ONLY: comin_host_errhandler_fct
  USE comin_descrdata_types, ONLY:  comin_glb2loc_index_lookup_fct
  USE comin_ftnlist_ifc,     ONLY: comin_ftnlist_new
  USE comin_keyval_ifc,      ONLY: comin_varmap_new
 
  USE iso_c_binding,         ONLY: c_int, c_ptr, c_funptr, c_f_procpointer, c_null_char, &
    &                              c_associated, c_null_ptr, c_loc, c_char, c_double, c_f_pointer
  IMPLICIT NONE
 
  PRIVATE
 
  PUBLIC :: comin_setup_check
  PUBLIC :: comin_plugin_primaryconstructor
  PUBLIC :: comin_setup_init
  PUBLIC :: comin_setup_finalize
  PUBLIC :: comin_current_get_plugin_info
  PUBLIC :: comin_plugin_init
  PUBLIC :: comin_descrdata_set_fct_glb2loc_cell
  PUBLIC :: comin_setup_errhandler
 
  abstract INTERFACE
    SUBROUTINE comin_plugin_init_fct(state_ptr, host_version, host_wp) BIND(C)
      IMPORT c_ptr, c_int, t_comin_setup_version_info
 
#ifndef __NVCOMPILER
      TYPE(C_PTR), VALUE, INTENT(IN)               :: state_ptr
#else
      TYPE(C_PTR), INTENT(IN)                      :: state_ptr
#endif
 
      TYPE(t_comin_setup_version_info), INTENT(IN) :: host_version
      INTEGER(C_INT), INTENT(IN)                   :: host_wp
    END SUBROUTINE comin_plugin_init_fct
 
    SUBROUTINE comin_primaryconstructor_fct() &
      &  BIND(C)
    END SUBROUTINE comin_primaryconstructor_fct
 
  END INTERFACE
 
  INTEGER(c_int), PARAMETER :: rtld_now    =   2 ! (value extracted from the C header file)
  !
  ! interface to linux API
  INTERFACE
    FUNCTION dlopen_ptr(filename,mode) BIND(c,name="dlopen")
      ! void *dlopen(const char *filename, int mode);
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_ptr) :: dlopen_ptr
      TYPE(c_ptr), VALUE, INTENT(in) :: filename
      INTEGER(c_int), VALUE :: mode
    END FUNCTION dlopen_ptr
 
    FUNCTION dlsym(handle,name) BIND(c,name="dlsym")
      ! void *dlsym(void *handle, const char *name);
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_funptr) :: dlsym
      TYPE(c_ptr), VALUE :: handle
      CHARACTER(c_char), INTENT(in) :: name(*)
    END FUNCTION dlsym
 
    ! FUNCTION dlclose(handle) BIND(c,name="dlclose")
    !   ! int dlclose(void *handle);
    !   USE iso_c_binding
    !   IMPLICIT NONE
    !   INTEGER(c_int) :: dlclose
    !   TYPE(c_ptr), VALUE :: handle
    ! END FUNCTION dlclose
 
    FUNCTION dlerror() RESULT(error) BIND(C,NAME="dlerror")
      ! char *dlerror(void);
      USE iso_c_binding
      TYPE(C_PTR) :: error
    END FUNCTION dlerror
 
  END INTERFACE
 
  ! list type
  TYPE :: comin_primaryconstructor_ptr
    PROCEDURE(comin_primaryconstructor_fct), POINTER, NOPASS :: fct_ptr
  END TYPE comin_primaryconstructor_ptr
 
  TYPE(c_ptr), ALLOCATABLE :: dl_handles(:)
 
#include "comin_version.inc"
 
CONTAINS
 
  FUNCTION dlopen(filename, mode)
    CHARACTER(LEN=*), INTENT(in) :: filename
    INTEGER(c_int), VALUE :: mode
    !
    TYPE(c_ptr) :: dlopen
    CHARACTER(len=1, kind=c_char), TARGET :: c_filename(len(filename)+1)
    CALL convert_f_string(trim(filename), c_filename)
    dlopen = dlopen_ptr(c_loc(c_filename), mode)
  END FUNCTION dlopen
 
  SUBROUTINE comin_plugin_primaryconstructor(plugin_list)
 
    TYPE(t_comin_plugin_description), INTENT(IN), TARGET :: plugin_list(:)
    !
    INTEGER :: i, last_sep_idx
    TYPE(c_funptr) :: setup_fct_c, plugin_init_fct_c
    PROCEDURE(comin_primaryconstructor_fct), BIND(C), POINTER :: setup_fct
    PROCEDURE(comin_plugin_init_fct), BIND(C), POINTER :: plugin_init_fct
 
    CALL comin_ftnlist_new(state%comin_callback_list)
    CALL comin_varmap_new(state%comin_var_list)
    CALL comin_ftnlist_new(state%comin_var_descr_list)
    CALL comin_ftnlist_new(state%comin_var_request_list)
 
    state%num_plugins = SIZE(plugin_list)
    ALLOCATE(dl_handles(state%num_plugins))
    ALLOCATE(state%plugin_info(state%num_plugins))
    DO i=1,state%num_plugins
 
      IF (trim(plugin_list(i)%plugin_library) .EQ. "") THEN
        dl_handles(i) = dlopen_ptr(c_null_ptr, rtld_now)
      ELSE
        dl_handles(i) = dlopen(plugin_list(i)%plugin_library, rtld_now)
      END IF
      IF (.NOT. c_associated(dl_handles(i))) &
        & CALL comin_plugin_finish("comin_plugin_primaryconstructor", &
        &                          "ERROR: Cannot load plugin " // convert_c_string(dlerror()))
 
      ! We load the symbol comin_plugin_init explicitly from the library
      plugin_init_fct_c = dlsym(dl_handles(i), "comin_plugin_init"//c_null_char)
      IF (.NOT. c_associated(plugin_init_fct_c))  &
        & CALL comin_plugin_finish("comin_plugin_primaryconstructor", &
        &                          "Cannot load 'comin_plugin_init' from plugin: " // convert_c_string(dlerror()))
      CALL c_f_procpointer( plugin_init_fct_c, plugin_init_fct )
      CALL plugin_init_fct(c_loc(state), comin_setup_get_version(), wp)
 
      setup_fct_c = dlsym(dl_handles(i), trim(plugin_list(i)%primary_constructor)//c_null_char)
      IF (.NOT. c_associated(setup_fct_c))  &
        & CALL comin_plugin_finish("comin_plugin_primaryconstructor", &
        &                          "Cannot load primary constructor from plugin: " // convert_c_string(dlerror()))
 
      CALL c_f_procpointer( setup_fct_c, setup_fct )
      state%current_plugin => state%plugin_info(i)
      state%current_plugin%id = i
      IF (len_trim(plugin_list(i)%name) > 0) THEN
        state%current_plugin%name = trim(plugin_list(i)%name)
      ELSE
        last_sep_idx = scan(plugin_list(i)%plugin_library, "/", .true.)
        state%current_plugin%name = trim(plugin_list(i)%plugin_library(last_sep_idx+1:)) // &
          & "(" // trim(plugin_list(i)%primary_constructor) // ")"
      ENDIF
      state%current_plugin%options = trim(plugin_list(i)%options)
      state%current_plugin%comm = trim(plugin_list(i)%comm)
      state%current_plugin%log_debug = plugin_list(i)%log_debug
      state%current_plugin%log_info = plugin_list(i)%log_info
      state%current_plugin%log_warning = plugin_list(i)%log_warning
      CALL setup_fct()
      NULLIFY(state%current_plugin)
 
    END DO
 
    ! after all primary callbacks are done: finalize callback structure and set flag
    CALL comin_callback_complete()
    CALL comin_var_complete()
    state%l_primary_done = .true.
  END SUBROUTINE comin_plugin_primaryconstructor
 
  SUBROUTINE comin_setup_check(plugin_str, wp_check)
    CHARACTER(LEN=*), INTENT(IN)  :: plugin_str
    INTEGER,          INTENT(IN)  :: wp_check
    !
 
    IF (.NOT. ASSOCIATED(state%comin_host_finish)) THEN
      CALL comin_error_set(comin_error_setup_errhandler_not_set); RETURN
    END IF
 
    ! compare floating point precision
    IF (wp /= wp_check) THEN
      CALL comin_error_set(comin_error_setup_precision_test_failed); RETURN
    ELSE
      CALL comin_message("     " // plugin_str // ": working precision test successful.", 0)
    END IF
  END SUBROUTINE comin_setup_check
 
  SUBROUTINE comin_current_get_plugin_info(comin_current_plugin)
    TYPE(t_comin_plugin_info), INTENT(OUT)   :: comin_current_plugin
 
    comin_current_plugin = state%current_plugin
 
  END SUBROUTINE comin_current_get_plugin_info
 
  INTEGER(C_INT) FUNCTION  comin_current_get_plugin_id() &
    & BIND(C, NAME="comin_current_get_plugin_id")
    comin_current_get_plugin_id = int(state%current_plugin%id, c_int)
  END FUNCTION comin_current_get_plugin_id
 
  SUBROUTINE comin_current_get_plugin_name(val, len) &
    & BIND(C, NAME="comin_current_get_plugin_name")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%current_plugin%name)
    len = len_trim(state%current_plugin%name)
  END SUBROUTINE comin_current_get_plugin_name
 
  SUBROUTINE comin_current_get_plugin_options(val, len) &
    & BIND(C, NAME="comin_current_get_plugin_options")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%current_plugin%options)
    len = len_trim(state%current_plugin%options)
  END SUBROUTINE comin_current_get_plugin_options
 
  SUBROUTINE comin_current_get_plugin_comm(val, len) &
    & BIND(C, NAME="comin_current_get_plugin_comm")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%current_plugin%comm)
    len = len_trim(state%current_plugin%comm)
  END SUBROUTINE comin_current_get_plugin_comm
 
  SUBROUTINE comin_setup_init(lstdout, output_unit)
    LOGICAL, INTENT(IN)           :: lstdout
    INTEGER, INTENT(IN), OPTIONAL :: output_unit
    IF (ASSOCIATED(state)) THEN
      ! <! cant use comin_message due to circular dependencies
      CALL comin_error_set(comin_error_setup_comin_already_initialized); RETURN
    END IF
    ALLOCATE(state)
    state%lstdout = lstdout
    IF(PRESENT(output_unit)) THEN
      state%output_unit = output_unit
    END IF
  END SUBROUTINE comin_setup_init
 
  SUBROUTINE comin_setup_finalize()
    !
    ! INTEGER :: i
    ! INTEGER(c_int) :: ierr_c
 
    CALL comin_parallel_free_mpi_comms()
 
    ! we don't call dlclose in the finalization because it has no
    ! advantages, while it would triggers some problems:
    !
    ! - NVHPC compilers for GPU try to unload the library again in at
    ! the end of the program resulting in a segfault. See
    ! https://gitlab.dkrz.de/icon-comin/comin/-/issues/210
    !
    ! - parallel HDF5 registers calls backs at `MPI_COMM_SELF` atexit
    ! handler, which also results in a segfault as the call gets
    ! unloaded in dlclose before the handler is called.
    ! See https://gitlab.dkrz.de/icon-comin/comin/-/issues/214
    !
 
    ! DO i=1,SIZE(dl_handles)
    !   ierr_c = dlclose(dl_handles(i))
    !   IF (ierr_c /= 0) THEN
    !     CALL comin_error_set(COMIN_ERROR_SETUP_FINALIZE)
    !   END IF
    ! END DO
    DEALLOCATE(dl_handles, state%plugin_info)
  END SUBROUTINE comin_setup_finalize
 
  ! This routine is called by the host to set the plugins state
  ! explicitly to the state of the host model. It should by loaded by
  ! the host explicitly from the shared library of the plugin by using
  ! `dlsym`.
  SUBROUTINE comin_plugin_init(state_ptr, host_version, host_wp) &
    BIND(C)
 
    ! At the moment assuming only NVHPC and GCC (default way)
    TYPE(c_ptr), VALUE, INTENT(IN)               :: state_ptr
    TYPE(t_comin_setup_version_info), INTENT(IN) :: host_version
    INTEGER(C_INT), INTENT(IN)                   :: host_wp
 
    TYPE(t_comin_state), POINTER :: host_state => null()
 
    ! we cant rely on calling methods to obtain the version or wp,
    ! because this might call functions dynamically loaded by the host
    ! or other plugins. Hence we use the version preprocessor and wp
    ! constants directly.
 
    IF( .NOT. comin_setup_version_compatible(host_version, &
         & t_comin_setup_version_info(comin_version_major, comin_version_minor, comin_version_patch))) THEN
      CALL comin_error_set(comin_error_plugin_init_comin_version); RETURN
    END IF
 
    IF( host_wp /= c_double ) THEN
      CALL comin_error_set(comin_error_plugin_init_precision); RETURN
    END IF
 
    CALL c_f_pointer(state_ptr, host_state)
 
    IF(ASSOCIATED(state) .AND. .NOT. ASSOCIATED(state, host_state)) THEN
      ! <! cant use comin_message due to circular dependencies
      CALL comin_error_set(comin_error_plugin_init_state_initialized); RETURN
    END IF
 
    state => host_state
  END SUBROUTINE comin_plugin_init
 
  SUBROUTINE comin_descrdata_set_fct_glb2loc_cell(fct)
    PROCEDURE(comin_glb2loc_index_lookup_fct) :: fct
    state%comin_descrdata_fct_glb2loc_cell => fct
    IF (.NOT. ASSOCIATED(state%comin_descrdata_fct_glb2loc_cell)) THEN
      CALL comin_error_set(comin_error_descrdata_set_fct_glb2loc); RETURN
    END IF
  END SUBROUTINE comin_descrdata_set_fct_glb2loc_cell
 
  SUBROUTINE comin_setup_errhandler(error_handler)
    PROCEDURE(comin_host_errhandler_fct) :: error_handler
 
    state%comin_host_finish => error_handler
    IF (.NOT. ASSOCIATED(state%comin_host_finish)) THEN
      CALL comin_error_set(comin_error_setup_errhandler_not_associated); RETURN
    END IF
  END SUBROUTINE comin_setup_errhandler
 
END MODULE comin_setup