! (C) Copyright 2026- 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_API_MOD USE PARKIND1, ONLY : JPIM, JPRB USE FIELD_ACCESS_MODULE, ONLY: GET_HOST_DATA_RDWR, GET_DEVICE_DATA_RDWR, GET_HOST_DATA_RDONLY,GET_DEVICE_DATA_RDONLY USE FIELD_BASIC_MODULE, ONLY: FIELD_BASIC USE FIELD_MODULE, ONLY:FIELD_1RB, FIELD_2RB, FIELD_3RB, FIELD_4RB, FIELD_2RB_VIEW, FIELD_3RB_VIEW USE ECTRANS_FIELD_VIEW_MOD, ONLY: FIELD_VIEW, FIELD_VIEW_INIT, FIELD_VIEW_SET_DATA_PTR, FIELD_VIEW_SET_NAME, & & FIELD_VIEW_SET_IVSET_PTR, & & FIELD_VIEW_SET_ACCESS, & & FIELD_VIEW_INDEXING, FIELD_VIEW_ACCESS USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT IMPLICIT NONE PRIVATE PUBLIC :: FIELD_GRID, FIELD_SPEC, MAKE_FIELD_GRID, MAKE_FIELD_SPEC, MAKE_FIELD_VIEW TYPE FIELD_GRID ! A pointer to field API field with additional METADATA CLASS (FIELD_BASIC), POINTER :: PTR ! POINTER TO FIELD_BASIC from field API CHARACTER(LEN=10) :: NAME ! Name INTEGER(KIND=JPIM) :: DIM_V ! Vertical dimension (0 if not applicable) END TYPE TYPE FIELD_SPEC ! A pointer to field API field with additional METADATA CLASS (FIELD_BASIC), POINTER :: PTR ! POINTER TO FIELD_BASIC from field API CHARACTER(LEN=10) :: NAME ! Name INTEGER(KIND=JPIM), ALLOCATABLE :: IVSET(:) ! b-set for spectral fields END TYPE INTERFACE MAKE_FIELD_GRID MODULE PROCEDURE :: MAKE_FIELD_GRID_1RB, MAKE_FIELD_GRID_2RB, MAKE_FIELD_GRID_3RB, MAKE_FIELD_GRID_4RB END INTERFACE INTERFACE MAKE_FIELD_SPEC MODULE PROCEDURE :: MAKE_FIELD_SPEC_1RB, MAKE_FIELD_SPEC_2RB, MAKE_FIELD_SPEC_3RB END INTERFACE INTERFACE MAKE_FIELD_VIEW MODULE PROCEDURE :: MAKE_FIELD_VIEW_SPEC, MAKE_FIELD_VIEW_GRID END INTERFACE ! We use ABOR1 and not ABORT_TRANS because ABORT_TRANS is to be private to trans routines, ! and this interface is conceptually outside trans. #include "abor1.intfb.h" CONTAINS SUBROUTINE PREVENT_COMPILER_OPTIMISATION(F) TYPE(FIELD_SPEC), TARGET, INTENT(INOUT) :: F INTEGER(KIND=JPIM), POINTER, VOLATILE, SAVE :: IVSET_DUMMY(:) IF (ALLOCATED(F%IVSET)) THEN IVSET_DUMMY => F%IVSET ELSE IVSET_DUMMY => NULL() END IF END SUBROUTINE PREVENT_COMPILER_OPTIMISATION FUNCTION MAKE_FIELD_SPEC_1RB(YLF,NAME,IVSET) ! Creation of a FIELD_SPEC encapsulating a FIELD_1RB field TYPE (FIELD_SPEC) :: MAKE_FIELD_SPEC_1RB CLASS (FIELD_1RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: IVSET(:) MAKE_FIELD_SPEC_1RB%PTR => YLF MAKE_FIELD_SPEC_1RB%NAME = NAME IF (PRESENT(IVSET)) THEN ALLOCATE(MAKE_FIELD_SPEC_1RB%IVSET(SIZE(IVSET))) MAKE_FIELD_SPEC_1RB%IVSET = IVSET ENDIF CALL PREVENT_COMPILER_OPTIMISATION(MAKE_FIELD_SPEC_1RB) END FUNCTION MAKE_FIELD_SPEC_1RB FUNCTION MAKE_FIELD_SPEC_2RB(YLF,NAME,IVSET) ! Creation of a FIELD_SPEC encapsulating a FIELD_2RB field TYPE (FIELD_SPEC) :: MAKE_FIELD_SPEC_2RB CLASS (FIELD_2RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: IVSET(:) MAKE_FIELD_SPEC_2RB%PTR => YLF MAKE_FIELD_SPEC_2RB%NAME = NAME IF (PRESENT(IVSET)) THEN ALLOCATE(MAKE_FIELD_SPEC_2RB%IVSET(SIZE(IVSET))) MAKE_FIELD_SPEC_2RB%IVSET = IVSET ENDIF CALL PREVENT_COMPILER_OPTIMISATION(MAKE_FIELD_SPEC_2RB) END FUNCTION MAKE_FIELD_SPEC_2RB FUNCTION MAKE_FIELD_SPEC_3RB(YLF,NAME,IVSET) ! Creation of a FIELD_SPEC encapsulating a FIELD_3RB field TYPE (FIELD_SPEC) :: MAKE_FIELD_SPEC_3RB CLASS (FIELD_3RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: IVSET(:) MAKE_FIELD_SPEC_3RB%PTR => YLF MAKE_FIELD_SPEC_3RB%NAME = NAME IF (PRESENT(IVSET)) THEN ALLOCATE(MAKE_FIELD_SPEC_3RB%IVSET(SIZE(IVSET))) MAKE_FIELD_SPEC_3RB%IVSET = IVSET ENDIF CALL PREVENT_COMPILER_OPTIMISATION(MAKE_FIELD_SPEC_3RB) END FUNCTION MAKE_FIELD_SPEC_3RB FUNCTION MAKE_FIELD_GRID_1RB(YLF,NAME) ! Creation of a FIELD_GRID encapsulating a FIELD_1RB field TYPE (FIELD_GRID) :: MAKE_FIELD_GRID_1RB CLASS (FIELD_1RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME MAKE_FIELD_GRID_1RB%PTR => YLF MAKE_FIELD_GRID_1RB%NAME = NAME MAKE_FIELD_GRID_1RB%DIM_V = 0 END FUNCTION MAKE_FIELD_GRID_1RB FUNCTION MAKE_FIELD_GRID_2RB(YLF,NAME) ! Creation of a FIELD_GRID encapsulating a FIELD_2RB field TYPE (FIELD_GRID) :: MAKE_FIELD_GRID_2RB CLASS (FIELD_2RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME MAKE_FIELD_GRID_2RB%PTR => YLF MAKE_FIELD_GRID_2RB%NAME = NAME MAKE_FIELD_GRID_2RB%DIM_V = 0 END FUNCTION MAKE_FIELD_GRID_2RB FUNCTION MAKE_FIELD_GRID_3RB(YLF,NAME) ! Creation of a FIELD_GRID encapsulating a FIELD_3RB field TYPE (FIELD_GRID) :: MAKE_FIELD_GRID_3RB CLASS (FIELD_3RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME MAKE_FIELD_GRID_3RB%PTR => YLF MAKE_FIELD_GRID_3RB%NAME = NAME MAKE_FIELD_GRID_3RB%DIM_V = 1 END FUNCTION MAKE_FIELD_GRID_3RB FUNCTION MAKE_FIELD_GRID_4RB(YLF,NAME) ! Creation of a FIELD_SPEC encapsulating a FIELD_4RB field TYPE (FIELD_GRID) :: MAKE_FIELD_GRID_4RB CLASS (FIELD_4RB), INTENT(IN), POINTER :: YLF CHARACTER(LEN=*), INTENT(IN) :: NAME MAKE_FIELD_GRID_4RB%PTR => YLF MAKE_FIELD_GRID_4RB%NAME = NAME MAKE_FIELD_GRID_4RB%DIM_V = 1 END FUNCTION MAKE_FIELD_GRID_4RB SUBROUTINE MAKE_FIELD_VIEW_SPEC(YLFV, YLF, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV TYPE(FIELD_SPEC), INTENT(IN) :: YLF LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY CALL FIELD_VIEW_INIT(YLFV) CALL SET_ACCESS(YLFV, LDACC, LDRDONLY) SELECT TYPE (FIELD => YLF%PTR) CLASS IS (FIELD_1RB) CALL SET_DATA_1RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%SPEC2 CLASS IS (FIELD_2RB) CALL SET_DATA_2RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%LEVEL_SPEC2 CALL SET_IVSET(YLFV, YLF%IVSET) CLASS IS (FIELD_3RB) CALL SET_DATA_3RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%LEVEL_SPEC2_FIELD CALL SET_IVSET(YLFV, YLF%IVSET) CLASS IS (FIELD_4RB) CALL ABOR1("MAKE_FIELD_VIEW FAILURE: SPECTRAL FIELDS OF RANK 4 ARE NOT SUPPORTED") CLASS DEFAULT CALL ABOR1("MAKE_FIELD_VIEW FAILURE: CLASS UNKNOWN") END SELECT CALL FIELD_VIEW_SET_NAME(YLFV, YLF%NAME) END SUBROUTINE SUBROUTINE MAKE_FIELD_VIEW_GRID(YLFV, YLF, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV TYPE(FIELD_GRID), INTENT(IN) :: YLF LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY CALL FIELD_VIEW_INIT(YLFV) CALL SET_ACCESS(YLFV, LDACC, LDRDONLY) SELECT TYPE (FIELD => YLF%PTR) CLASS IS (FIELD_1RB) CALL SET_DATA_1RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%BLOCK ! Treats NPROMA=1 CLASS IS (FIELD_2RB) CALL SET_DATA_2RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%NPROMA_BLOCK CLASS IS (FIELD_3RB) CALL SET_DATA_3RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%NPROMA_LEVEL_BLOCK CLASS IS (FIELD_4RB) CALL SET_DATA_4RB(YLFV, FIELD, LDACC, LDRDONLY) YLFV%INDEXING = FIELD_VIEW_INDEXING%NPROMA_LEVEL_FIELD_BLOCK CLASS DEFAULT CALL ABOR1("MAKE_FIELD_VIEW FAILURE: CLASS UNKNOWN") END SELECT CALL FIELD_VIEW_SET_NAME(YLFV, YLF%NAME) END SUBROUTINE ! ------------------------------------------------------------------------------------------------ ! Private helper subroutines for setting data access modes for different field types ! ------------------------------------------------------------------------------------------------ SUBROUTINE SET_ACCESS(YLFV, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY IF (LDACC) THEN IF (LDRDONLY) THEN CALL FIELD_VIEW_SET_ACCESS(YLFV, FIELD_VIEW_ACCESS%DEVICE, FIELD_VIEW_ACCESS%READONLY) ELSE CALL FIELD_VIEW_SET_ACCESS(YLFV, FIELD_VIEW_ACCESS%DEVICE) ENDIF ELSE IF (LDRDONLY) THEN CALL FIELD_VIEW_SET_ACCESS(YLFV, FIELD_VIEW_ACCESS%HOST, FIELD_VIEW_ACCESS%READONLY) ELSE CALL FIELD_VIEW_SET_ACCESS(YLFV, FIELD_VIEW_ACCESS%HOST) ENDIF ENDIF END SUBROUTINE SUBROUTINE SET_DATA_1RB(YLFV, FIELD, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV CLASS(FIELD_1RB), POINTER, INTENT(IN) :: FIELD LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY REAL(JPRB), POINTER :: PTR(:) IF (LDACC) THEN IF (LDRDONLY) THEN CALL FIELD%GET_DEVICE_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_DEVICE_DATA_RDWR(PTR) ENDIF ELSE IF (LDRDONLY) THEN CALL FIELD%GET_HOST_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_HOST_DATA_RDWR(PTR) ENDIF ENDIF CALL FIELD_VIEW_SET_DATA_PTR(YLFV, PTR) END SUBROUTINE SUBROUTINE SET_DATA_2RB(YLFV, FIELD, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV CLASS(FIELD_2RB), POINTER, INTENT(IN) :: FIELD LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY REAL(JPRB), POINTER :: PTR(:,:) IF (LDACC) THEN IF (LDRDONLY) THEN CALL FIELD%GET_DEVICE_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_DEVICE_DATA_RDWR(PTR) ENDIF ELSE IF (LDRDONLY) THEN CALL FIELD%GET_HOST_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_HOST_DATA_RDWR(PTR) ENDIF ENDIF CALL FIELD_VIEW_SET_DATA_PTR(YLFV, PTR) END SUBROUTINE SUBROUTINE SET_DATA_3RB(YLFV, FIELD, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV CLASS(FIELD_3RB), POINTER, INTENT(IN) :: FIELD LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY REAL(JPRB), POINTER :: PTR(:,:,:) IF (LDACC) THEN IF (LDRDONLY) THEN CALL FIELD%GET_DEVICE_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_DEVICE_DATA_RDWR(PTR) ENDIF ELSE IF (LDRDONLY) THEN CALL FIELD%GET_HOST_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_HOST_DATA_RDWR(PTR) ENDIF ENDIF CALL FIELD_VIEW_SET_DATA_PTR(YLFV, PTR) END SUBROUTINE SUBROUTINE SET_DATA_4RB(YLFV, FIELD, LDACC, LDRDONLY) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV CLASS(FIELD_4RB), POINTER, INTENT(IN) :: FIELD LOGICAL, INTENT(IN) :: LDACC LOGICAL, INTENT(IN) :: LDRDONLY REAL(JPRB), POINTER :: PTR(:,:,:,:) IF (LDACC) THEN IF (LDRDONLY) THEN CALL FIELD%GET_DEVICE_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_DEVICE_DATA_RDWR(PTR) ENDIF ELSE IF (LDRDONLY) THEN CALL FIELD%GET_HOST_DATA_RDONLY(PTR) ELSE CALL FIELD%GET_HOST_DATA_RDWR(PTR) ENDIF ENDIF CALL FIELD_VIEW_SET_DATA_PTR(YLFV, PTR) END SUBROUTINE SUBROUTINE SET_IVSET(YLFV, IVSET) TYPE(FIELD_VIEW), INTENT(INOUT) :: YLFV INTEGER(C_INT), TARGET, ALLOCATABLE, INTENT(IN) :: IVSET(:) CALL FIELD_VIEW_SET_IVSET_PTR(YLFV, IVSET) END SUBROUTINE END MODULE ECTRANS_FIELD_API_MOD