simple_fortran_plugin.F90

Go to the documentation of this file.

! --------------------------------------------------------------------
!  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
  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_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"
 
  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
 
  TYPE(t_comin_descrdata_domain),     POINTER   :: p_patch
  TYPE(t_comin_descrdata_global),     POINTER   :: p_global
  TYPE(t_comin_descrdata_simulation_interval), POINTER   :: p_simulation_interval
 
  TYPE(t_comin_var_handle),  ALLOCATABLE :: qv(:)
 
  CHARACTER(LEN=200)            :: text
 
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
 
    CALL comin_current_get_plugin_info(this_plugin)
    WRITE (text,'(a,i4)') "     plugin  id: ", this_plugin%id
    CALL comin_print_info(text)
 
 
    ! 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_patch    => comin_descrdata_get_domain(1)
    p_global   => comin_descrdata_get_global()
    p_simulation_interval    => comin_descrdata_get_simulation_interval()
 
    dtime_1 = comin_descrdata_get_timesteplength(1)
    dtime_2 = comin_descrdata_get_timesteplength(2)
    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)          :: descriptor
 
    CALL comin_print_info("third party callback: secondary constructor.")
    CALL comin_print_info("third party callback: iterate over variable list:")
 
    it = comin_var_get_descr_list_head()
    DO WHILE (c_associated(it))
      CALL comin_var_get_descr_list_var_desc(it, descriptor)
      WRITE (text,*) "Variable found: ", trim(descriptor%name), &
        "(", descriptor%id, ")"
      CALL comin_print_info(text)
      it = comin_var_get_descr_list_next(it)
    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%n_dom))
    DO jg =1, p_global%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
    REAL(wp)                        :: 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()
 
    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
 
    DO jg =1, p_global%n_dom
      comm      = comin_parallel_get_host_mpi_comm()
      CALL qv(jg)%get_ptr(qv_ptr)
      local_max = maxval(qv_ptr)
      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
 
END MODULE simple_fortran_plugin