ectrans_field_view_mod.F90

This file depends on

Help
Files dependent on this one

Help
Source Code

! (C) Copyright 2001- ECMWF.
! (C) Copyright 2001- Meteo-France.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.

MODULE ECTRANS_FIELD_VIEW_MOD

! Must stay precision independent (i.e. do not use parkind or JPRB)

USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT, C_INTPTR_T, C_LOC, C_F_POINTER, C_FLOAT, C_DOUBLE, C_NULL_PTR
USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS

IMPLICIT NONE

PRIVATE

PUBLIC :: FIELD_VIEW, FIELD_VIEW_INIT, FIELD_VIEW_SET_DATA_PTR, FIELD_VIEW_GET_DATA_PTR
PUBLIC :: FIELD_VIEW_SET_IVSET_PTR, FIELD_VIEW_GET_IVSET_PTR
PUBLIC :: FIELD_VIEW_SET_NAME, FIELD_VIEW_GET_NAME_PTR
PUBLIC :: FIELD_VIEW_GET_EXTENT, FIELD_VIEW_GET_STRIDE, FIELD_VIEW_GET_DIM_ROLE, FIELD_VIEW_GET_EXTENT_BY_ROLE
PUBLIC :: FIELD_VIEW_SET_ACCESS, FIELD_VIEW_ADD_ACCESS, FIELD_VIEW_HAS_ACCESS, FIELD_VIEW_CLEAR_ACCESS
PUBLIC :: FIELD_VIEW_DIM_ROLE, FIELD_VIEW_INDEXING, FIELD_VIEW_ACCESS_TYPE, FIELD_VIEW_ACCESS

INTEGER, PARAMETER :: MAX_RANK = 4

! MEMORY ACCESS
INTEGER(C_INT), PARAMETER :: &
  & ACCESS_UNKNOWN  = 0, &
  & ACCESS_HOST     = 1, &
  & ACCESS_DEVICE   = 2, &
  & ACCESS_READONLY = 4

TYPE :: FIELD_VIEW_ACCESS_TYPE
  INTEGER(C_INT) :: UNKNOWN  = ACCESS_UNKNOWN
  INTEGER(C_INT) :: HOST     = ACCESS_HOST
  INTEGER(C_INT) :: DEVICE   = ACCESS_DEVICE
  INTEGER(C_INT) :: READONLY = ACCESS_READONLY
END TYPE FIELD_VIEW_ACCESS_TYPE

TYPE(FIELD_VIEW_ACCESS_TYPE), SAVE, PROTECTED :: FIELD_VIEW_ACCESS

! DIMENSION ROLES
INTEGER(C_INT), PARAMETER :: &
  & DIM_UNKNOWN = 0, &
  & DIM_NPROMA  = 1, &
  & DIM_BLOCK   = 2, &
  & DIM_LEVEL   = 3, &
  & DIM_FIELD   = 4, &
  & DIM_SPEC2   = 5

TYPE :: FIELD_VIEW_DIM_ROLE_TYPE
  INTEGER(C_INT) :: UNKNOWN = DIM_UNKNOWN
  INTEGER(C_INT) :: NPROMA  = DIM_NPROMA
  INTEGER(C_INT) :: BLOCK   = DIM_BLOCK
  INTEGER(C_INT) :: LEVEL   = DIM_LEVEL
  INTEGER(C_INT) :: FIELD   = DIM_FIELD
  INTEGER(C_INT) :: SPEC2   = DIM_SPEC2
END TYPE FIELD_VIEW_DIM_ROLE_TYPE

TYPE(FIELD_VIEW_DIM_ROLE_TYPE), SAVE, PROTECTED :: FIELD_VIEW_DIM_ROLE

INTEGER, PARAMETER :: DIM_ROLE_BITS = 4

! INDEXING uses C dimension ordering. The least-significant role describes EXTENTS(1).
! C array shapes represented by the indexing values.
INTEGER(C_INT), PARAMETER :: &
  & INDEXING_UNKNOWN                    = DIM_UNKNOWN, &
  & C_INDEXING_BLOCK                    = DIM_BLOCK,                                          & ! array[NBLKS]
  & C_INDEXING_BLOCK_NPROMA             = IOR(DIM_BLOCK, ISHFT(DIM_NPROMA, DIM_ROLE_BITS)),   & ! array[NBLKS][NPROMA]
  & C_INDEXING_BLOCK_LEVEL_NPROMA       = IOR(DIM_BLOCK, IOR(ISHFT(DIM_LEVEL, DIM_ROLE_BITS), & ! array[NBLKS][NLEVS][NPROMA]
                                        & ISHFT(DIM_NPROMA, 2 * DIM_ROLE_BITS))),             &
  & C_INDEXING_BLOCK_FIELD_LEVEL_NPROMA = IOR(DIM_BLOCK, IOR(ISHFT(DIM_FIELD, DIM_ROLE_BITS), & ! array[NBLKS][NFIELDS][NLEVS][NPROMA]
                                        & IOR(ISHFT(DIM_LEVEL, 2 * DIM_ROLE_BITS),            &
                                        & ISHFT(DIM_NPROMA, 3 * DIM_ROLE_BITS)))),            &
  & C_INDEXING_SPEC2                    = DIM_SPEC2,                                          & ! array[NSPEC2]
  & C_INDEXING_SPEC2_LEVEL              = IOR(DIM_SPEC2, ISHFT(DIM_LEVEL, DIM_ROLE_BITS)),    & ! array[NSPEC2][NLEVS]
  & C_INDEXING_FIELD_SPEC2_LEVEL        = IOR(DIM_FIELD, IOR(ISHFT(DIM_SPEC2, DIM_ROLE_BITS), & ! array[NFIELDS][NSPEC2][NLEVS]
                                        & ISHFT(DIM_LEVEL, 2 * DIM_ROLE_BITS)))

! Fortran array shapes represented by the C-ordered indexing values.
TYPE :: FIELD_VIEW_INDEXING_TYPE
  INTEGER(C_INT) :: UNKNOWN                  = INDEXING_UNKNOWN
  INTEGER(C_INT) :: BLOCK                    = C_INDEXING_BLOCK                    ! ARRAY(NBLKS)
  INTEGER(C_INT) :: NPROMA_BLOCK             = C_INDEXING_BLOCK_NPROMA             ! ARRAY(NPROMA, NBLKS)
  INTEGER(C_INT) :: NPROMA_LEVEL_BLOCK       = C_INDEXING_BLOCK_LEVEL_NPROMA       ! ARRAY(NPROMA, NLEVS, NBLKS)
  INTEGER(C_INT) :: NPROMA_LEVEL_FIELD_BLOCK = C_INDEXING_BLOCK_FIELD_LEVEL_NPROMA ! ARRAY(NPROMA, NLEVS, NFIELDS, NBLKS)
  INTEGER(C_INT) :: SPEC2                    = C_INDEXING_SPEC2                    ! ARRAY(NSPEC2)
  INTEGER(C_INT) :: LEVEL_SPEC2              = C_INDEXING_SPEC2_LEVEL              ! ARRAY(NLEVS, NSPEC2)
  INTEGER(C_INT) :: LEVEL_SPEC2_FIELD        = C_INDEXING_FIELD_SPEC2_LEVEL        ! ARRAY(NLEVS, NSPEC2, NFIELDS)
END TYPE FIELD_VIEW_INDEXING_TYPE

TYPE(FIELD_VIEW_INDEXING_TYPE), SAVE, PROTECTED :: FIELD_VIEW_INDEXING

! C-interoperable view of field data and its shape, stride, and dimension-role metadata.
! Array metadata uses C dimension ordering. Spectral fields may additionally reference
! an IVSET array assigning each level to a spectral distribution set.
TYPE, BIND(C) :: FIELD_VIEW

  ! ARRAY
  TYPE(C_PTR)    :: DATA
  INTEGER(C_INT) :: ACCESS
  INTEGER(C_INT) :: KIND
  INTEGER(C_INT) :: RANK
  INTEGER(C_INT) :: EXTENTS(MAX_RANK) ! C ORDERING
  INTEGER(C_INT) :: STRIDES(MAX_RANK) ! C ORDERING

  ! IVSET
  TYPE(C_PTR)    :: IVSET ! Value indexing is specified by IVSET_BASE
  INTEGER(C_INT) :: IVSET_SIZE
  INTEGER(C_INT) :: IVSET_BASE ! 0 for zero-based values, 1 for one-based values

  ! NAME
  TYPE(C_PTR)    :: NAME
  INTEGER(C_INT) :: NAME_SIZE

  ! INDEXING
  INTEGER(C_INT) :: INDEXING ! NOTE: C ORDERING

END TYPE

INTERFACE FIELD_VIEW_GET_DATA_PTR
  MODULE PROCEDURE :: GET_DATA_PTR_1RM, GET_DATA_PTR_2RM, GET_DATA_PTR_3RM, GET_DATA_PTR_4RM
  MODULE PROCEDURE :: GET_DATA_PTR_1RD, GET_DATA_PTR_2RD, GET_DATA_PTR_3RD, GET_DATA_PTR_4RD
END INTERFACE

INTERFACE FIELD_VIEW_SET_DATA_PTR
  MODULE PROCEDURE :: SET_DATA_PTR_1RM, SET_DATA_PTR_2RM, SET_DATA_PTR_3RM, SET_DATA_PTR_4RM
  MODULE PROCEDURE :: SET_DATA_PTR_1RD, SET_DATA_PTR_2RD, SET_DATA_PTR_3RD, SET_DATA_PTR_4RD
END INTERFACE

INTERFACE FIELD_VIEW_SET_ACCESS
  MODULE PROCEDURE :: SET_ACCESS_1, SET_ACCESS_2, SET_ACCESS_3
END INTERFACE

INTERFACE FIELD_VIEW_ADD_ACCESS
  MODULE PROCEDURE :: ADD_ACCESS_1, ADD_ACCESS_2, ADD_ACCESS_3
END INTERFACE

INTERFACE FIELD_VIEW_HAS_ACCESS
  MODULE PROCEDURE :: HAS_ACCESS_1, HAS_ACCESS_2, HAS_ACCESS_3
END INTERFACE

CONTAINS

PURE SUBROUTINE FIELD_VIEW_INIT(YLFV)
  TYPE(FIELD_VIEW), INTENT(OUT) :: YLFV
  YLFV%DATA = C_NULL_PTR
  YLFV%ACCESS = ACCESS_UNKNOWN
  YLFV%KIND = 0
  YLFV%RANK = 0
  YLFV%EXTENTS = 0
  YLFV%STRIDES = 0
  YLFV%IVSET = C_NULL_PTR
  YLFV%IVSET_SIZE = 0
  YLFV%IVSET_BASE = 1
  YLFV%NAME = C_NULL_PTR
  YLFV%NAME_SIZE = 0
  YLFV%INDEXING = INDEXING_UNKNOWN
END SUBROUTINE

PURE SUBROUTINE FIELD_VIEW_CLEAR_ACCESS(YLFV)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  YLFV%ACCESS = ACCESS_UNKNOWN
END SUBROUTINE

PURE SUBROUTINE SET_ACCESS_1(YLFV, ACCESS1)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1
  YLFV%ACCESS = ACCESS1
END SUBROUTINE

PURE SUBROUTINE SET_ACCESS_2(YLFV, ACCESS1, ACCESS2)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2
  YLFV%ACCESS = IOR(ACCESS1, ACCESS2)
END SUBROUTINE

PURE SUBROUTINE SET_ACCESS_3(YLFV, ACCESS1, ACCESS2, ACCESS3)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2, ACCESS3
  YLFV%ACCESS = IOR(ACCESS1, IOR(ACCESS2, ACCESS3))
END SUBROUTINE

PURE SUBROUTINE ADD_ACCESS_1(YLFV, ACCESS1)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1
  YLFV%ACCESS = IOR(YLFV%ACCESS, ACCESS1)
END SUBROUTINE

PURE SUBROUTINE ADD_ACCESS_2(YLFV, ACCESS1, ACCESS2)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2
  YLFV%ACCESS = IOR(YLFV%ACCESS, IOR(ACCESS1, ACCESS2))
END SUBROUTINE

PURE SUBROUTINE ADD_ACCESS_3(YLFV, ACCESS1, ACCESS2, ACCESS3)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2, ACCESS3
  YLFV%ACCESS = IOR(YLFV%ACCESS, IOR(ACCESS1, IOR(ACCESS2, ACCESS3)))
END SUBROUTINE

PURE FUNCTION HAS_ACCESS_1(YLFV, ACCESS1) RESULT(ENABLED)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1
  LOGICAL :: ENABLED
  ENABLED = IAND(YLFV%ACCESS, ACCESS1) == ACCESS1
END FUNCTION

PURE FUNCTION HAS_ACCESS_2(YLFV, ACCESS1, ACCESS2) RESULT(ENABLED)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2
  LOGICAL :: ENABLED
  ENABLED = IAND(YLFV%ACCESS, IOR(ACCESS1, ACCESS2)) == IOR(ACCESS1, ACCESS2)
END FUNCTION

PURE FUNCTION HAS_ACCESS_3(YLFV, ACCESS1, ACCESS2, ACCESS3) RESULT(ENABLED)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: ACCESS1, ACCESS2, ACCESS3
  LOGICAL :: ENABLED
  ENABLED = IAND(YLFV%ACCESS, IOR(ACCESS1, IOR(ACCESS2, ACCESS3))) == IOR(ACCESS1, IOR(ACCESS2, ACCESS3))
END FUNCTION

SUBROUTINE SET_DATA_PTR_METADATA(YLFV, DATA, KIND, RANK, FORTRAN_EXTENTS, FORTRAN_OFFSETS)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  TYPE(C_PTR), INTENT(IN) :: DATA
  INTEGER(C_INT), INTENT(IN) :: KIND ! bytes of data type (e.g., 4 for REAL(C_FLOAT), 8 for REAL(C_DOUBLE))
  INTEGER(C_INT), INTENT(IN) :: RANK
  INTEGER(C_INT), INTENT(IN) :: FORTRAN_EXTENTS(RANK)
  INTEGER(C_INTPTR_T), INTENT(IN) :: FORTRAN_OFFSETS(RANK)
  INTEGER(C_INT) :: FORTRAN_STRIDES(RANK)
  INTEGER :: JDIM, JFIRST

  YLFV%DATA = DATA
  YLFV%KIND = KIND
  YLFV%RANK = RANK
  YLFV%EXTENTS = 0
  YLFV%STRIDES = 0

  IF (PRODUCT(FORTRAN_EXTENTS) == 1) THEN
    FORTRAN_STRIDES = 1
  ELSE
    FORTRAN_STRIDES = 0
    JFIRST = 0
    DO JDIM = 1, RANK
      IF (FORTRAN_OFFSETS(JDIM) /= 0) THEN
        JFIRST = JDIM
        EXIT
      ENDIF
    ENDDO
    IF (JFIRST > 0) FORTRAN_STRIDES(1) = FORTRAN_OFFSETS(JFIRST) / KIND
    DO JDIM = 2, RANK
      IF (FORTRAN_OFFSETS(JDIM) /= 0) THEN
        FORTRAN_STRIDES(JDIM) = FORTRAN_OFFSETS(JDIM) / KIND
      ELSE
        FORTRAN_STRIDES(JDIM) = FORTRAN_STRIDES(JDIM-1) * FORTRAN_EXTENTS(JDIM-1)
      ENDIF
    ENDDO
  ENDIF

  DO JDIM = 1, RANK
    YLFV%EXTENTS(RANK-JDIM+1) = FORTRAN_EXTENTS(JDIM)
    YLFV%STRIDES(RANK-JDIM+1) = FORTRAN_STRIDES(JDIM)
  ENDDO
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_1RM(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(IN) :: PTR(:)
  INTEGER(C_INT), PARAMETER :: RANK = 1
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_1RD(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(IN) :: PTR(:)
  INTEGER(C_INT), PARAMETER :: RANK = 1
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_2RM(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(IN) :: PTR(:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 2
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_2RD(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(IN) :: PTR(:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 2
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_3RM(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(IN) :: PTR(:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 3
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2,1)), BASE) - BASE
  IF (SIZE(PTR, 3) > 1) OFFSETS(3) = TRANSFER(C_LOC(PTR(1,1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_3RD(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(IN) :: PTR(:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 3
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2,1)), BASE) - BASE
  IF (SIZE(PTR, 3) > 1) OFFSETS(3) = TRANSFER(C_LOC(PTR(1,1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_4RM(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(IN) :: PTR(:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 4
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1,1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1,1,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2,1,1)), BASE) - BASE
  IF (SIZE(PTR, 3) > 1) OFFSETS(3) = TRANSFER(C_LOC(PTR(1,1,2,1)), BASE) - BASE
  IF (SIZE(PTR, 4) > 1) OFFSETS(4) = TRANSFER(C_LOC(PTR(1,1,1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

SUBROUTINE SET_DATA_PTR_4RD(YLFV, PTR)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(IN) :: PTR(:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 4
  INTEGER(C_INT) :: EXTENTS(RANK)
  INTEGER(C_INTPTR_T) :: BASE, OFFSETS(RANK)
  TYPE(C_PTR) :: DATA
  DATA = C_LOC(PTR(1,1,1,1))
  BASE = TRANSFER(DATA, BASE)
  EXTENTS = SHAPE(PTR)
  OFFSETS = 0
  IF (SIZE(PTR, 1) > 1) OFFSETS(1) = TRANSFER(C_LOC(PTR(2,1,1,1)), BASE) - BASE
  IF (SIZE(PTR, 2) > 1) OFFSETS(2) = TRANSFER(C_LOC(PTR(1,2,1,1)), BASE) - BASE
  IF (SIZE(PTR, 3) > 1) OFFSETS(3) = TRANSFER(C_LOC(PTR(1,1,2,1)), BASE) - BASE
  IF (SIZE(PTR, 4) > 1) OFFSETS(4) = TRANSFER(C_LOC(PTR(1,1,1,2)), BASE) - BASE
  CALL SET_DATA_PTR_METADATA(YLFV, DATA, STORAGE_SIZE(PTR)/8, RANK, EXTENTS, OFFSETS)
END SUBROUTINE

PURE FUNCTION FIELD_VIEW_GET_EXTENT(YLFV, FORTRAN_DIM) RESULT(EXTENT)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER, INTENT(IN) :: FORTRAN_DIM
  INTEGER(C_INT) :: EXTENT
  EXTENT = YLFV%EXTENTS(YLFV%RANK-FORTRAN_DIM+1)
END FUNCTION

PURE FUNCTION FIELD_VIEW_GET_STRIDE(YLFV, FORTRAN_DIM) RESULT(STRIDE)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER, INTENT(IN) :: FORTRAN_DIM
  INTEGER(C_INT) :: STRIDE
  STRIDE = YLFV%STRIDES(YLFV%RANK-FORTRAN_DIM+1)
END FUNCTION

PURE FUNCTION FIELD_VIEW_GET_DIM_ROLE(YLFV, FORTRAN_DIM) RESULT(ROLE)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER, INTENT(IN) :: FORTRAN_DIM
  INTEGER(C_INT) :: ROLE
  INTEGER(C_INT) :: C_DIM
  INTEGER(C_INT), PARAMETER :: DIM_ROLE_MASK = INT(Z'F', C_INT)
  C_DIM = YLFV%RANK-FORTRAN_DIM+1
  ROLE = IAND(ISHFT(YLFV%INDEXING, -DIM_ROLE_BITS * (C_DIM - 1)), DIM_ROLE_MASK)
END FUNCTION

PURE FUNCTION FIELD_VIEW_GET_EXTENT_BY_ROLE(YLFV, DIM_ROLE) RESULT(EXTENT)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER, INTENT(IN) :: DIM_ROLE
  INTEGER(C_INT) :: EXTENT
  INTEGER :: FORTRAN_DIM
  EXTENT = 0
  DO FORTRAN_DIM = 1, YLFV%RANK
    IF (FIELD_VIEW_GET_DIM_ROLE(YLFV, FORTRAN_DIM) == DIM_ROLE) THEN
      EXTENT = FIELD_VIEW_GET_EXTENT(YLFV, FORTRAN_DIM)
      RETURN
    ENDIF
  ENDDO
END FUNCTION

SUBROUTINE FIELD_VIEW_SET_NAME(YLFV, NAME)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  CHARACTER(LEN=*), TARGET, INTENT(IN) :: NAME
  YLFV%NAME = C_LOC(NAME(1:1))
  YLFV%NAME_SIZE = LEN_TRIM(NAME)
END SUBROUTINE

SUBROUTINE FIELD_VIEW_GET_NAME_PTR(YLFV, NAME)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  CHARACTER(LEN=:), POINTER, INTENT(INOUT) :: NAME
  CHARACTER(LEN=YLFV%NAME_SIZE), POINTER :: F_STR
  CALL C_F_POINTER(YLFV%NAME, F_STR)
  NAME => F_STR
END SUBROUTINE

SUBROUTINE ASSERT_EXPECTED_RANK_AND_KIND(LABEL, YLFV, EXPECTED_RANK, EXPECTED_KIND)
  IMPLICIT NONE
  CHARACTER(LEN=*), INTENT(IN) :: LABEL
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER(C_INT), INTENT(IN) :: EXPECTED_RANK
  INTEGER(C_INT), INTENT(IN) :: EXPECTED_KIND
  IF (YLFV%RANK /= EXPECTED_RANK) THEN
    BLOCK
      CHARACTER(LEN=:), POINTER :: NAME
      CALL FIELD_VIEW_GET_NAME_PTR(YLFV, NAME)
      CALL ABORT_TRANS(TRIM(LABEL)//" FAILURE: FIELD "//TRIM(NAME)//" RANK MUST BE "//&
        & TRIM(TO_STR(EXPECTED_RANK))//" BUT IS "//TRIM(TO_STR(YLFV%RANK)))
    END BLOCK
  ENDIF
  IF (YLFV%KIND /= EXPECTED_KIND) THEN
    BLOCK
      CHARACTER(LEN=:), POINTER :: NAME
      CALL FIELD_VIEW_GET_NAME_PTR(YLFV, NAME)
      CALL ABORT_TRANS(TRIM(LABEL)//" FAILURE: FIELD "//TRIM(NAME)//" KIND MUST BE "//&
        & TRIM(TO_STR(EXPECTED_KIND))//" BUT IS "//TRIM(TO_STR(YLFV%KIND)))
    END BLOCK
  ENDIF
  CONTAINS
  FUNCTION TO_STR(I) RESULT(STR)
    INTEGER, INTENT(IN) :: I
    CHARACTER(LEN=32) :: STR
    WRITE(STR, '(I0)') I
  END FUNCTION TO_STR
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_1RM(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_FLOAT), POINTER :: PTR(:)
  INTEGER(C_INT), PARAMETER :: RANK = 1
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_1RM", YLFV, RANK, C_FLOAT)
  IF (FIELD_VIEW_GET_STRIDE(YLFV, 1) == 1) THEN
    CALL C_F_POINTER(YLFV%DATA, PTR, [FIELD_VIEW_GET_EXTENT(YLFV, 1)])
  ELSE
    BLOCK
      REAL(C_FLOAT), POINTER :: BACKING(:,:)
      INTEGER(C_INT) :: EXTENTS(RANK+1)
      EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
      EXTENTS(2) = FIELD_VIEW_GET_EXTENT(YLFV, 1)
      CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
      PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1))
    END BLOCK
  ENDIF
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_1RD(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: PTR(:)
  INTEGER(C_INT), PARAMETER :: RANK = 1
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_1RD", YLFV, RANK, C_DOUBLE)
  IF (FIELD_VIEW_GET_STRIDE(YLFV, 1) == 1) THEN
    CALL C_F_POINTER(YLFV%DATA, PTR, [FIELD_VIEW_GET_EXTENT(YLFV, 1)])
  ELSE
    BLOCK
      REAL(C_DOUBLE), POINTER :: BACKING(:,:)
      INTEGER(C_INT) :: EXTENTS(RANK+1)
      EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
      EXTENTS(2) = FIELD_VIEW_GET_EXTENT(YLFV, 1)
      CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
      PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1))
    END BLOCK
  ENDIF
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_2RM(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(INOUT) :: PTR(:,:)
  REAL(C_FLOAT), POINTER :: BACKING(:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 2
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_2RM", YLFV, RANK, C_FLOAT)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2))
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_2RD(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: PTR(:,:)
  REAL(C_DOUBLE), POINTER :: BACKING(:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 2
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_2RD", YLFV, RANK, C_DOUBLE)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2))
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_3RM(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(INOUT) :: PTR(:,:,:)
  REAL(C_FLOAT), POINTER :: BACKING(:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 3
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_3RM", YLFV, RANK, C_FLOAT)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2), &
    & 1:FIELD_VIEW_GET_EXTENT(YLFV, 3))
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_3RD(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: PTR(:,:,:)
  REAL(C_DOUBLE), POINTER :: BACKING(:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 3
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_3RD", YLFV, RANK, C_DOUBLE)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2), &
    & 1:FIELD_VIEW_GET_EXTENT(YLFV, 3))
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_4RM(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_FLOAT), POINTER, INTENT(INOUT) :: PTR(:,:,:,:)
  REAL(C_FLOAT), POINTER :: BACKING(:,:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 4
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_4RM", YLFV, RANK, C_FLOAT)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2), &
    & 1:FIELD_VIEW_GET_EXTENT(YLFV, 3), 1:FIELD_VIEW_GET_EXTENT(YLFV, 4))
END SUBROUTINE

SUBROUTINE GET_DATA_PTR_4RD(YLFV, PTR)
  IMPLICIT NONE
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: PTR(:,:,:,:)
  REAL(C_DOUBLE), POINTER :: BACKING(:,:,:,:,:)
  INTEGER(C_INT), PARAMETER :: RANK = 4
  INTEGER(C_INT) :: EXTENTS(RANK+1), JDIM
  CALL ASSERT_EXPECTED_RANK_AND_KIND("GET_DATA_PTR_4RD", YLFV, RANK, C_DOUBLE)
  EXTENTS(1) = FIELD_VIEW_GET_STRIDE(YLFV, 1)
  DO JDIM=1,RANK-1
    EXTENTS(JDIM+1) = FIELD_VIEW_GET_STRIDE(YLFV, JDIM+1)/FIELD_VIEW_GET_STRIDE(YLFV, JDIM)
  ENDDO
  EXTENTS(RANK+1) = FIELD_VIEW_GET_EXTENT(YLFV, RANK)
  CALL C_F_POINTER(YLFV%DATA, BACKING, EXTENTS)
  PTR => BACKING(1, 1:FIELD_VIEW_GET_EXTENT(YLFV, 1), 1:FIELD_VIEW_GET_EXTENT(YLFV, 2), &
    & 1:FIELD_VIEW_GET_EXTENT(YLFV, 3), 1:FIELD_VIEW_GET_EXTENT(YLFV, 4))
END SUBROUTINE

SUBROUTINE FIELD_VIEW_SET_IVSET_PTR(YLFV, IVSET, IVSET_BASE)
  TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV
  INTEGER(KIND=C_INT), TARGET, OPTIONAL, INTENT(IN) :: IVSET(:)
  INTEGER(KIND=C_INT), OPTIONAL, INTENT(IN) :: IVSET_BASE
  YLFV%IVSET_BASE = 1
  IF (PRESENT(IVSET_BASE)) YLFV%IVSET_BASE = IVSET_BASE
  IF (PRESENT(IVSET)) THEN
    IF (SIZE(IVSET) > 0) THEN
      YLFV%IVSET = C_LOC(IVSET(1))
      YLFV%IVSET_SIZE = SIZE(IVSET)
      RETURN
    ENDIF
  ENDIF
  YLFV%IVSET = C_NULL_PTR
  YLFV%IVSET_SIZE = 0
END SUBROUTINE

SUBROUTINE FIELD_VIEW_GET_IVSET_PTR(YLFV, IVSET)
  TYPE(FIELD_VIEW), INTENT(IN) :: YLFV
  INTEGER(KIND=C_INT), POINTER, INTENT(INOUT) :: IVSET(:)
  IF (YLFV%IVSET_SIZE == 0) THEN
    NULLIFY(IVSET)
  ELSE
    CALL C_F_POINTER(YLFV%IVSET, IVSET, [YLFV%IVSET_SIZE])
  ENDIF
END SUBROUTINE

END MODULE ECTRANS_FIELD_VIEW_MOD
ectrans_field_view_mod.F90 Source File

Contents

Modules

Source Code

This file depends on

Files dependent on this one

Source Code
