simple_fortran_plugin.F90

Go to the documentation of this file.

! --------------------------------------------------------------------
!> Example plugin for the ICON Community Interface (ComIn)
!  with basic (not MPI-parallel) callbacks and accessing variables and
!  descriptive data structures.
!
!  Note that in order to demonstrate ComIn's language interoperability,
!  a similary plugin has been implemented in C, see the subdirectory
!  "simple_c".
!
!
!  @authors 01/2023 :: ICON Community INTERFACE  <comin@icon-model.org>
!
!  SPDX-License-Identifier: BSD-3-Clause
!
!  Please see the file LICENSE in the root of the source tree for this code.
!  Where software is supplied by third parties, it is indicated in the
!  headers of the routines.
! --------------------------------------------------------------------
MODULE simple_fortran_plugin
  USE mpi
  USE iso_c_binding,           ONLY : c_int, c_ptr, c_f_pointer, c_associated, c_sizeof, c_loc,         &
    &                                 c_funloc, c_size_t
  USE comin_plugin_interface,  ONLY : comin_callback_register,                                          &
    &                                 comin_var_get, comin_parallel_get_host_mpi_comm,                  &
    &                                 t_comin_var_descriptor, t_comin_var_handle,                       &
    &                                 comin_var_request_add,                                            &
    &                                 comin_descrdata_get_domain, t_comin_descrdata_domain,             &
    &                                 comin_descrdata_get_global, t_comin_descrdata_global,             &
    &                                 comin_descrdata_get_cell_block_limits,                            &
    &                                 comin_descrdata_get_cell_indices,                                 &
    &                                 comin_descrdata_get_simulation_interval,                          &
    &                                 t_comin_descrdata_simulation_interval,                            &
    &                                 t_comin_setup_version_info, comin_setup_get_version,              &
    &                                 ep_secondary_constructor, ep_destructor,                          &
    &                                 ep_atm_physics_before, ep_atm_write_output_before,                &
    &                                 comin_flag_read, comin_flag_write, comin_zaxis_2d,                &
    &                                 comin_parallel_get_host_mpi_rank, comin_current_get_domain_id,    &
    &                                 comin_domain_outside_loop, comin_callback_get_ep_name,            &
    &                                 t_comin_plugin_info, comin_current_get_plugin_info,               &
    &                                 comin_plugin_finish, comin_metadata_set,                          &
    &                                 comin_metadata_get,                                               &
    &                                 comin_descrdata_get_timesteplength, comin_hgrid_unstructured_edge,&
    &                                 comin_error_check, comin_var_get_descr_list_head,                 &
    &                                 comin_var_get_descr_list_next, comin_var_get_descr_list_var_desc, &
    &                                 comin_error_check, comin_print_info,                              &
    &                                 comin_dim_semantics_nproma, comin_dim_semantics_level,            &
    &                                 comin_dim_semantics_block, comin_dim_semantics_unused,            &
    &                                 comin_var_datatype_double
 
  IMPLICIT NONE
 
  CHARACTER(LEN=*), PARAMETER :: pluginname = "simple_fortran_plugin"
 
  !> working precision
  INTEGER, PARAMETER :: wp = selected_real_kind(12,307)
  TYPE(t_comin_setup_version_info) :: version
 
  TYPE(t_comin_var_handle)           :: pres, vn, simple_fortran_var, simple_fortran_tracer
  INTEGER                         :: rank
 
  !> access descriptive data structures
  TYPE(t_comin_descrdata_global) :: p_global
  TYPE(t_comin_descrdata_simulation_interval)   :: p_simulation_interval
 
  TYPE(t_comin_var_handle),  ALLOCATABLE :: qv(:)
 
  CHARACTER(LEN=200)            :: text
 
  INTERFACE
    SUBROUTINE qsort(arr, nmemb, size, pred) BIND(C)
      use, INTRINSIC :: iso_c_binding, only: c_ptr, c_size_t, c_funptr
      TYPE(c_ptr), VALUE, INTENT(IN) :: arr
      INTEGER(c_size_t), VALUE, INTENT(IN) :: nmemb, size
      TYPE(c_funptr), VALUE, INTENT(IN) :: pred
    END SUBROUTINE
  END INTERFACE
 
CONTAINS
 
  ! --------------------------------------------------------------------
  ! ComIn primary constructor.
  ! --------------------------------------------------------------------
  SUBROUTINE comin_main()  BIND(C)
    !
    TYPE(t_comin_plugin_info) :: this_plugin
    TYPE(t_comin_var_descriptor)  :: simple_fortran_d, simple_fortran_tracer_d
    REAL(wp)                      :: dtime_1, dtime_2
 
    rank = comin_parallel_get_host_mpi_rank()
    CALL comin_print_info("setup")
 
    version = comin_setup_get_version()
    IF (version%version_no_major > 1)  THEN
      CALL comin_plugin_finish("comin_main (simple_fortran_plugin)", "incompatible version!")
    END IF
 
    !> check plugin id
    CALL comin_current_get_plugin_info(this_plugin)
    WRITE (text,'(a,i4)') "     plugin  id: ", this_plugin%id
    CALL comin_print_info(text)
 
    !> add requests for additional ICON variables
 
    ! request host model to add variable simple_fortran_var
    simple_fortran_d = t_comin_var_descriptor(id = 1, name = "simple_fortran_var")
    CALL comin_var_request_add(simple_fortran_d, .false.)
    CALL comin_metadata_set(simple_fortran_d, "tracer", .false.)
    CALL comin_metadata_set(simple_fortran_d, "restart", .false.)
 
    ! request host model to add tracer simple_fortran_tracer
    simple_fortran_tracer_d = t_comin_var_descriptor( id = -1, name = "simple_fortran_tracer" )
    CALL comin_var_request_add(simple_fortran_tracer_d, .false.)
    CALL comin_metadata_set(simple_fortran_tracer_d, "tracer", .true.)
    CALL comin_metadata_set(simple_fortran_tracer_d, "restart", .false.)
 
    ! register callbacks
    CALL comin_callback_register(ep_secondary_constructor,   simple_fortran_constructor)
    CALL comin_callback_register(ep_atm_write_output_before, simple_fortran_diagfct)
    CALL comin_callback_register(ep_destructor,              simple_fortran_destructor)
 
    ! get descriptive data structures
    p_global = comin_descrdata_get_global()
    p_simulation_interval = comin_descrdata_get_simulation_interval()
 
    dtime_1 = comin_descrdata_get_timesteplength(1)
    IF(p_global%get_n_dom() > 1) THEN
      dtime_2 = comin_descrdata_get_timesteplength(2)
    ELSE
      dtime_2 = 0
    ENDIF
    WRITE(text,"(A,F5.0,F5.0)") "     timesteplength from comin_descrdata_get_timesteplength", dtime_1, dtime_2
    CALL comin_print_info(text)
  END SUBROUTINE comin_main
 
  ! --------------------------------------------------------------------
  ! ComIn secondary constructor.
  ! --------------------------------------------------------------------
  SUBROUTINE simple_fortran_constructor()  BIND(C)
    TYPE(t_comin_var_descriptor)          :: var_desc
    INTEGER                               :: jg, hgrid_id, datatype
    LOGICAL                               :: tracer, multi_timelevel
    REAL(WP), POINTER                     :: tracer_slice(:,:,:)
    TYPE(c_ptr)                           :: it
 
    TYPE(t_comin_var_descriptor), TARGET, ALLOCATABLE :: descrs(:), temp(:)
    INTEGER(c_size_t) :: descrs_len, descrs_size
    INTEGER(c_size_t) :: i
 
    CALL comin_print_info("third party callback: secondary constructor.")
    CALL comin_print_info("third party callback: iterate over variable list:")
 
    descrs_len = 0_c_size_t
    descrs_size = 8_c_size_t
    ALLOCATE(descrs(descrs_size))
 
    it = comin_var_get_descr_list_head()
    DO WHILE (c_associated(it))
      IF (descrs_len == descrs_size) THEN
        descrs_size = descrs_size * 2
        ALLOCATE(temp(descrs_size))
        temp(1:descrs_len) = descrs(1:descrs_len)
        CALL move_alloc(temp, descrs)
      END IF
 
      descrs_len = descrs_len + 1
 
      CALL comin_var_get_descr_list_var_desc(it, descrs(descrs_len))
      it = comin_var_get_descr_list_next(it)
    END DO
 
    CALL qsort(c_loc(descrs(1)), descrs_len, storage_size(descrs, c_size_t) / 8, c_funloc(compare_descr))
 
    DO i = 1, descrs_len
      WRITE (text,*) "Variable found: ", trim(descrs(i)%name), &
        "(", descrs(i)%id, ")"
      CALL comin_print_info(text)
    END DO
 
    WRITE (text,*) "     ", pluginname, " - register some variables in some context"
    CALL comin_print_info(text)
    var_desc = t_comin_var_descriptor('pres', 1)
    CALL comin_var_get([ep_atm_write_output_before], &
      &                 var_desc, comin_flag_read, pres)
    IF (.NOT. pres%valid()) &
      &  CALL comin_plugin_finish("simple_fortran_constructor", "Internal error!")
 
    IF (any(pres%dim_semantics() /= [comin_dim_semantics_nproma, &
         &                           comin_dim_semantics_level,  &
         &                           comin_dim_semantics_block,  &
         &                           comin_dim_semantics_unused,  &
         &                           comin_dim_semantics_unused ])) &
      &  CALL comin_plugin_finish("simple_fortran_constructor", "Dimension check failed!")
 
    var_desc = t_comin_var_descriptor('vn', 1)
    CALL comin_var_get([ep_atm_write_output_before], &
      &                 var_desc, comin_flag_read, vn)
    IF (.NOT. vn%valid()) &
      &  CALL comin_plugin_finish("simple_fortran_constructor vn", "Internal error!")
 
    CALL comin_metadata_get(var_desc, "hgrid_id", hgrid_id)
    IF (hgrid_id/=comin_hgrid_unstructured_edge) &
      &  CALL comin_plugin_finish("comin_var_get_metadata_hgrid", "Internal error!")
    CALL comin_metadata_get(var_desc, "multi_timelevel", multi_timelevel)
 
    ALLOCATE(qv(p_global%get_n_dom()))
    DO jg =1, p_global%get_n_dom()
      CALL comin_var_get([ep_atm_write_output_before], &
           &             t_comin_var_descriptor(name='qv', id=jg), &
           &             comin_flag_read, qv(jg))
      CALL comin_metadata_get(t_comin_var_descriptor(name='qv', id=jg), &
           &             "datatype", datatype)
      IF (datatype/=comin_var_datatype_double) &
           &  CALL comin_plugin_finish("simple_fortran_constructor", "Internal error!")
      IF (.NOT. qv(jg)%valid()) &
        &  CALL comin_plugin_finish("simple_fortran_constructor", "Internal error!")
 
      IF (any(qv(jg)%dim_semantics() /= [ comin_dim_semantics_nproma, &
           &                              comin_dim_semantics_level,  &
           &                              comin_dim_semantics_block,  &
           &                              comin_dim_semantics_unused,  &
           &                              comin_dim_semantics_unused ] )) &
      &  CALL comin_plugin_finish("simple_fortran_constructor", "Dimension check failed!")
    END DO
 
    CALL comin_var_get([ep_atm_write_output_before], &
         &                t_comin_var_descriptor(name="simple_fortran_var", id=1), &
         &                comin_flag_write, simple_fortran_var)
    IF (.NOT. simple_fortran_var%valid()) &
      &  CALL comin_plugin_finish("simple_fortran_constructor", "Internal error!")
 
    CALL comin_metadata_get(t_comin_var_descriptor(name="simple_fortran_var", id=1), &
      &                     "tracer", tracer)
 
    CALL comin_var_get([ep_atm_write_output_before], &
         &             t_comin_var_descriptor(name="simple_fortran_tracer", id=1), &
         &             comin_flag_write, simple_fortran_tracer)
    IF (.NOT. simple_fortran_tracer%valid()) &
      &  CALL comin_plugin_finish("simple_fortran_constructor", "Internal error!")
 
    ! access the "simple_fortran_tracer" via a 3D array pointer:
    CALL simple_fortran_tracer%to_3d(tracer_slice)
    tracer_slice(1,9,1) = 1.0
  END SUBROUTINE simple_fortran_constructor
 
  ! --------------------------------------------------------------------
  ! ComIn callback function.
  ! --------------------------------------------------------------------
  SUBROUTINE simple_fortran_diagfct()  BIND(C)
    INTEGER                         :: ierr, domain_id, jg, comm, root, &
         &                             jb, jbs, jbe, jcs, jce,          &
         &                             rl_start, rl_end
    REAL(wp)                        :: block_max, local_max, global_max
    REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: simple_fortran_ptr, &
         &                                     pres_ptr, qv_ptr
 
    CALL comin_print_info("third party callback: before output.")
 
    domain_id = comin_current_get_domain_id()
    comm = comin_parallel_get_host_mpi_comm()
 
    IF (domain_id == comin_domain_outside_loop) THEN
      CALL comin_print_info("currently not in domain loop")
    ELSE
      WRITE(text,'(a,i0)')  "      currently on domain ", domain_id
      CALL comin_print_info(text)
    END IF
 
    CALL simple_fortran_var%get_ptr(simple_fortran_ptr)
    CALL pres%get_ptr(pres_ptr)
    simple_fortran_ptr = pres_ptr + 42
 
    ! Start and end levels of prognostic cells.
    rl_start = p_global%get_grf_bdywidth_c() + 1
    rl_end = p_global%get_min_rlcell_int()
 
    DO jg =1, p_global%get_n_dom()
      CALL qv(jg)%get_ptr(qv_ptr)
 
      CALL comin_descrdata_get_cell_block_limits(jg, rl_start, rl_end, jbs, jbe)
      DO jb = jbs, jbe
        CALL comin_descrdata_get_cell_indices(jg, jb, jbs, jbe, jcs, jce, rl_start, rl_end)
 
        block_max = maxval(qv_ptr(jcs:jce,:,jb,1,1))
 
        IF (jb == jbs) THEN
          local_max = block_max
        ELSE
          local_max = max(local_max, block_max)
        END IF
      END DO
 
      root = 0
      CALL mpi_reduce(local_max, global_max, 1, mpi_double_precision, mpi_max, root, comm, ierr)
      WRITE(text,"(A,I8,A,F8.6)") "domain ", jg, ": global max = ", global_max
      CALL comin_print_info(text)
    END DO
  END SUBROUTINE simple_fortran_diagfct
 
  ! --------------------------------------------------------------------
  ! ComIn callback function.
  ! --------------------------------------------------------------------
  SUBROUTINE simple_fortran_destructor() BIND(C)
    CALL comin_print_info("third party callback: destructor.")
  END SUBROUTINE simple_fortran_destructor
 
  INTEGER(c_int) FUNCTION compare_descr(a, b) BIND(C)
    TYPE(c_ptr), VALUE, INTENT(IN) :: a, b
    TYPE(t_comin_var_descriptor), POINTER :: pa, pb
 
    CALL c_f_pointer(a, pa)
    CALL c_f_pointer(b, pb)
 
    IF (pa%name /= pb%name) THEN
      compare_descr = merge(-1, 1, pa%name < pb%name)
    ELSE
      compare_descr = pa%id - pb%id
    END IF
  END FUNCTION compare_descr
END MODULE simple_fortran_plugin