comin_descrdata.F90

Go to the documentation of this file.

 
!
!  @authors 10/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_descrdata
 
  use, INTRINSIC :: iso_c_binding, only: c_int, c_ptr, c_loc, c_bool
  USE comin_setup_constants, ONLY: wp
  USE comin_state,           ONLY: state
  USE comin_descrdata_types, ONLY: t_comin_descrdata_global,       &
    &                              t_comin_descrdata_domain,       &
    &                              t_comin_descrdata_simulation_interval,   &
    &                              t_comin_descrdata_domain_cells, &
    &                              t_comin_descrdata_domain_edges, &
    &                              t_comin_descrdata_domain_verts
  USE comin_errhandler,      ONLY: comin_plugin_finish
 
  IMPLICIT NONE
 
  PRIVATE
 
  PUBLIC :: comin_descrdata_set_global, comin_descrdata_get_global
  PUBLIC :: comin_descrdata_get_domain, comin_descrdata_set_domain
  PUBLIC :: comin_descrdata_set_simulation_interval, comin_descrdata_get_simulation_interval
  PUBLIC :: comin_descrdata_finalize
  PUBLIC :: comin_descrdata_get_index, comin_descrdata_get_block, comin_descrdata_get_cell_indices
  PUBLIC :: comin_descrdata_get_edge_indices, comin_descrdata_get_vert_indices
  PUBLIC :: comin_descrdata_get_cell_npromz, comin_descrdata_get_edge_npromz, comin_descrdata_get_vert_npromz
  PUBLIC :: comin_descrdata_index_lookup_glb2loc_cell
  PUBLIC :: comin_current_get_datetime
  PUBLIC :: comin_current_set_datetime
  PUBLIC :: comin_descrdata_set_timesteplength, comin_descrdata_get_timesteplength
 
#include "comin_global.inc"
 
CONTAINS
 
  SUBROUTINE comin_descrdata_set_global(comin_global_info)
    TYPE(t_comin_descrdata_global), INTENT(IN)  :: comin_global_info
    state%comin_descrdata_global = comin_global_info
  END SUBROUTINE comin_descrdata_set_global
 
  SUBROUTINE comin_descrdata_set_domain(comin_domain_info)
    TYPE(t_comin_descrdata_domain), INTENT(IN)  :: comin_domain_info(:)
    ALLOCATE(state%comin_descrdata_domain, source=comin_domain_info)
  END SUBROUTINE comin_descrdata_set_domain
 
  SUBROUTINE comin_descrdata_set_simulation_interval(comin_time_info)
    TYPE(t_comin_descrdata_simulation_interval), INTENT(IN)  :: comin_time_info
    state%comin_descrdata_simulation_interval = comin_time_info
  END SUBROUTINE comin_descrdata_set_simulation_interval
 
  SUBROUTINE comin_current_get_datetime(sim_time_current)
    CHARACTER(LEN=:), ALLOCATABLE, INTENT(OUT) :: sim_time_current
    sim_time_current = state%current_datetime
  END SUBROUTINE comin_current_get_datetime
 
  SUBROUTINE comin_current_get_datetime_c(val, len) &
    & BIND(C, NAME="comin_current_get_datetime")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%current_datetime)
    len = len_trim(state%current_datetime)
  END SUBROUTINE comin_current_get_datetime_c
 
  SUBROUTINE comin_current_set_datetime(sim_time_current)
    CHARACTER(LEN=*),  INTENT(IN) :: sim_time_current
    state%current_datetime = sim_time_current
  END SUBROUTINE comin_current_set_datetime
 
  FUNCTION comin_descrdata_get_global()
    TYPE(t_comin_descrdata_global), POINTER :: comin_descrdata_get_global
    ! local
 
    comin_descrdata_get_global => null()
    comin_descrdata_get_global => state%comin_descrdata_global
    IF(.NOT. ASSOCIATED(comin_descrdata_get_global)) THEN
      CALL comin_plugin_finish("comin_descrdata_get_global", " ERROR: Pointer not associated.")
    END IF
  END FUNCTION comin_descrdata_get_global
 
  FUNCTION comin_descrdata_get_domain(jg)
    INTEGER,                       INTENT(IN)  :: jg
    ! local
    TYPE(t_comin_descrdata_domain), POINTER    :: comin_descrdata_get_domain
 
    comin_descrdata_get_domain => null()
    comin_descrdata_get_domain => state%comin_descrdata_domain(jg)
    IF(.NOT. ASSOCIATED(comin_descrdata_get_domain)) THEN
      CALL comin_plugin_finish("comin_descrdata_get_domain", " ERROR: Pointer not associated.")
    END IF
 
  END FUNCTION comin_descrdata_get_domain
 
  FUNCTION comin_descrdata_get_simulation_interval()
    TYPE(t_comin_descrdata_simulation_interval), POINTER :: comin_descrdata_get_simulation_interval
 
    comin_descrdata_get_simulation_interval => state%comin_descrdata_simulation_interval
    IF(.NOT. ASSOCIATED(comin_descrdata_get_simulation_interval)) THEN
      CALL comin_plugin_finish("comin_descrdata_get_simulation_interval", " ERROR: Pointer not associated.")
    END IF
  END FUNCTION comin_descrdata_get_simulation_interval
 
  SUBROUTINE comin_descrdata_get_simulation_interval_exp_start(val, len) &
    & BIND(C, NAME="comin_descrdata_get_simulation_interval_exp_start")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%comin_descrdata_simulation_interval%exp_start)
    len = len_trim(state%comin_descrdata_simulation_interval%exp_start)
  END SUBROUTINE comin_descrdata_get_simulation_interval_exp_start
 
  SUBROUTINE comin_descrdata_get_simulation_interval_exp_stop(val, len) &
    & BIND(C, NAME="comin_descrdata_get_simulation_interval_exp_stop")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%comin_descrdata_simulation_interval%exp_stop)
    len = len_trim(state%comin_descrdata_simulation_interval%exp_stop)
  END SUBROUTINE comin_descrdata_get_simulation_interval_exp_stop
 
  SUBROUTINE comin_descrdata_get_simulation_interval_run_start(val, len) &
    & BIND(C, NAME="comin_descrdata_get_simulation_interval_run_start")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%comin_descrdata_simulation_interval%run_start)
    len = len_trim(state%comin_descrdata_simulation_interval%run_start)
  END SUBROUTINE comin_descrdata_get_simulation_interval_run_start
 
  SUBROUTINE comin_descrdata_get_simulation_interval_run_stop(val, len) &
    & BIND(C, NAME="comin_descrdata_get_simulation_interval_run_stop")
    TYPE(c_ptr),                    INTENT(OUT) :: val
    INTEGER(kind=c_int),            INTENT(OUT) :: len
 
    val = c_loc(state%comin_descrdata_simulation_interval%run_stop)
    len = len_trim(state%comin_descrdata_simulation_interval%run_stop)
  END SUBROUTINE comin_descrdata_get_simulation_interval_run_stop
 
  FUNCTION comin_descrdata_get_timesteplength(jg) BIND(C)
    REAL(wp) :: comin_descrdata_get_timesteplength
    INTEGER(c_int), INTENT(IN), VALUE :: jg
 
    comin_descrdata_get_timesteplength = state%comin_descrdata_timesteplength(jg)
  END FUNCTION comin_descrdata_get_timesteplength
 
  SUBROUTINE comin_descrdata_set_timesteplength(jg, dt_current)
    INTEGER,               INTENT(IN)  :: jg
    REAL(wp),              INTENT(IN)  :: dt_current
 
    IF (.NOT. ALLOCATED(state%comin_descrdata_timesteplength)) THEN
      ALLOCATE(state%comin_descrdata_timesteplength(state%comin_descrdata_global%n_dom+4))
    END IF
    state%comin_descrdata_timesteplength(jg) = dt_current
  END SUBROUTINE comin_descrdata_set_timesteplength
 
  SUBROUTINE comin_descrdata_finalize()
 
  END SUBROUTINE comin_descrdata_finalize
 
  !!
 
  !-------------------------------------------------------------------------
  ! The following two functions are for conversion of 1D to 2D indices and vice versa
  !
  ! Treatment of 0 (important for empty domains) and negative numbers:
  !
  ! Converting 1D => 2D:
  !
  ! 0 always is mapped to blk_no = 1, idx_no = 0
  ! negative numbers: Convert usings ABS(j) and negate idx_no
  !
  ! Thus: blk_no >= 1 always!
  !       idx_no > 0  for j > 0
  !       idx_no = 0  for j = 0
  !       idx_no < 0  for j < 0
  !
  ! This mimics mostly the behaviour of reshape_idx in mo_model_domimp_patches
  ! with a difference for nproma=1 and j=0 (where reshape_idx returns blk_no=0, idx_no=1)
  !
  ! The consistent treatment of 0 in the above way is very important for empty domains
  ! where start_index=1, end_index=0
  !
  ! Converting 2D => 1D:
  ! Trying to invert the above and catching cases with blk_no < 1
  !-------------------------------------------------------------------------
 
  INTEGER(c_int) FUNCTION comin_descrdata_get_block(idx1D) BIND(C, name="comin_descrdata_get_block")
    INTEGER(c_int), INTENT(IN), VALUE :: idx1d
    comin_descrdata_get_block = max((abs(idx1d)-1)/state%comin_descrdata_global%nproma + 1, 1) ! i.e. also 1 for idx1D=0, nproma=1
  END FUNCTION comin_descrdata_get_block
 
  INTEGER(c_int) FUNCTION comin_descrdata_get_index(idx1D) BIND(C, name="comin_descrdata_get_index")
    INTEGER(c_int), INTENT(IN), VALUE :: idx1d
    IF(idx1d==0) THEN
      comin_descrdata_get_index = 0
    ELSE
      comin_descrdata_get_index = sign(mod(abs(idx1d)-1,state%comin_descrdata_global%nproma)+1, idx1d)
    ENDIF
  END FUNCTION comin_descrdata_get_index
 
  SUBROUTINE comin_descrdata_get_cell_indices(jg, i_blk, i_startblk, i_endblk, i_startidx, &
       i_endidx, irl_start, irl_end) &
    &  BIND(C, NAME="comin_descrdata_get_cell_indices")
 
    INTEGER(c_int), INTENT(IN), VALUE :: jg         ! Patch index for comin_domain
    INTEGER(c_int), INTENT(IN), VALUE :: i_blk      ! Current block (variable jb in do loops)
    INTEGER(c_int), INTENT(IN), VALUE :: i_startblk ! Start block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: i_endblk   ! End block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: irl_start  ! refin_ctrl level where do loop starts
    INTEGER(c_int), INTENT(IN), VALUE :: irl_end    ! refin_ctrl level where do loop ends
 
    INTEGER(c_int), INTENT(OUT) :: i_startidx, i_endidx ! Start and end indices (jc loop)
 
    IF (i_blk == i_startblk) THEN
      i_startidx = max(1,state%comin_descrdata_domain(jg)%cells%start_index(irl_start))
      i_endidx   = state%comin_descrdata_global%nproma
      IF (i_blk == i_endblk) i_endidx = state%comin_descrdata_domain(jg)%cells%end_index(irl_end)
    ELSE IF (i_blk == i_endblk) THEN
      i_startidx = 1
      i_endidx   = state%comin_descrdata_domain(jg)%cells%end_index(irl_end)
    ELSE
      i_startidx = 1
      i_endidx = state%comin_descrdata_global%nproma
    ENDIF
 
  END SUBROUTINE comin_descrdata_get_cell_indices
 
  SUBROUTINE comin_descrdata_get_edge_indices(jg, i_blk, i_startblk, i_endblk, i_startidx, &
       i_endidx, irl_start, irl_end) &
    &  BIND(C, NAME="comin_descrdata_get_edge_indices")
 
    INTEGER(c_int), INTENT(IN), VALUE :: jg         ! Patch index for comin_domain
    INTEGER(c_int), INTENT(IN), VALUE :: i_blk      ! Current block (variable jb in do loops)
    INTEGER(c_int), INTENT(IN), VALUE :: i_startblk ! Start block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: i_endblk   ! End block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: irl_start  ! refin_ctrl level where do loop starts
    INTEGER(c_int), INTENT(IN), VALUE :: irl_end    ! refin_ctrl level where do loop ends
 
    INTEGER(c_int), INTENT(OUT) :: i_startidx, i_endidx ! Start and end indices (jc loop)
 
    i_startidx = merge(1, &
                       max(1, state%comin_descrdata_domain(jg)%edges%start_index(irl_start)), &
                       i_blk /= i_startblk)
    i_endidx   = merge(state%comin_descrdata_global%nproma, &
                       state%comin_descrdata_domain(jg)%edges%end_index(irl_end), &
                       i_blk /= i_endblk)
 
  END SUBROUTINE comin_descrdata_get_edge_indices
 
  SUBROUTINE comin_descrdata_get_vert_indices(jg, i_blk, i_startblk, i_endblk, i_startidx, &
       i_endidx, irl_start, irl_end) &
    &  BIND(C, NAME="comin_descrdata_get_vert_indices")
 
    INTEGER(c_int), INTENT(IN), VALUE :: jg         ! Patch index for comin_domain
    INTEGER(c_int), INTENT(IN), VALUE :: i_blk      ! Current block (variable jb in do loops)
    INTEGER(c_int), INTENT(IN), VALUE :: i_startblk ! Start block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: i_endblk   ! End block of do loop
    INTEGER(c_int), INTENT(IN), VALUE :: irl_start  ! refin_ctrl level where do loop starts
    INTEGER(c_int), INTENT(IN), VALUE :: irl_end    ! refin_ctrl level where do loop ends
 
    INTEGER(c_int), INTENT(OUT) :: i_startidx, i_endidx ! Start and end indices (jc loop)
 
    IF (i_blk == i_startblk) THEN
      i_startidx = state%comin_descrdata_domain(jg)%verts%start_index(irl_start)
      i_endidx   = state%comin_descrdata_global%nproma
      IF (i_blk == i_endblk) i_endidx = state%comin_descrdata_domain(jg)%verts%end_index(irl_end)
    ELSE IF (i_blk == i_endblk) THEN
      i_startidx = 1
      i_endidx   = state%comin_descrdata_domain(jg)%verts%end_index(irl_end)
    ELSE
      i_startidx = 1
      i_endidx = state%comin_descrdata_global%nproma
    ENDIF
 
  END SUBROUTINE comin_descrdata_get_vert_indices
 
  INTEGER(c_int) FUNCTION comin_descrdata_get_cell_npromz(jg) BIND(C)
    INTEGER(c_int),  INTENT(IN), VALUE  :: jg     ! domain index for comin_domain
 
    comin_descrdata_get_cell_npromz = state%comin_descrdata_domain(jg)%cells%ncells - &
             &  (state%comin_descrdata_domain(jg)%cells%nblks-1)*state%comin_descrdata_global%nproma
  END FUNCTION comin_descrdata_get_cell_npromz
 
  INTEGER(c_int) FUNCTION comin_descrdata_get_edge_npromz(jg) BIND(C)
    INTEGER(c_int),  INTENT(IN), VALUE  :: jg     ! domain index for comin_domain
 
    comin_descrdata_get_edge_npromz = state%comin_descrdata_domain(jg)%edges%nedges - &
             &  (state%comin_descrdata_domain(jg)%edges%nblks-1)*state%comin_descrdata_global%nproma
  END FUNCTION comin_descrdata_get_edge_npromz
 
  INTEGER(c_int) FUNCTION comin_descrdata_get_vert_npromz(jg) BIND(C)
    INTEGER(c_int),  INTENT(IN), VALUE  :: jg     ! domain index for comin_domain
 
    comin_descrdata_get_vert_npromz = state%comin_descrdata_domain(jg)%verts%nverts - &
             &  (state%comin_descrdata_domain(jg)%verts%nblks-1)*state%comin_descrdata_global%nproma
  END FUNCTION comin_descrdata_get_vert_npromz
 
  INTEGER(C_INT) FUNCTION comin_descrdata_index_lookup_glb2loc_cell(jg, global_idx) &
    & result(loc) BIND(C)
    INTEGER(kind=C_INT), INTENT(IN), VALUE :: jg
    INTEGER(kind=C_INT), INTENT(IN), VALUE :: global_idx
    loc = state%comin_descrdata_fct_glb2loc_cell(jg, int(global_idx))
  END FUNCTION comin_descrdata_index_lookup_glb2loc_cell
 
  ! Query topo data routines generated by python script (comin_descrdata_get_domain.F90.py) in ../utils. !
#include "comin_descrdata_query_domain.inc"
 
  ! Query global data routines generated by python script (comin_descrdata_get_global.F90.py) in ../utils. !
#include "comin_descrdata_query_global.inc"
 
END MODULE comin_descrdata