! (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_INTERNAL_UTIL_MOD ! This module contains utility functions for the ECTRANS API taking FIELD_VIEW as input ! IMPORTANT! All types and functions in this module should not be exposed as external facing API. USE PARKIND1, ONLY : JPIM, JPRB USE ECTRANS_FIELD_VIEW_MOD, ONLY : FIELD_VIEW, FIELD_VIEW_GET_DATA_PTR, FIELD_VIEW_GET_NAME_PTR, FIELD_VIEW_GET_IVSET_PTR, & & FIELD_VIEW_GET_EXTENT, FIELD_VIEW_GET_DIM_ROLE, FIELD_VIEW_GET_EXTENT_BY_ROLE, & & FIELD_VIEW_DIM_ROLE USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS IMPLICIT NONE PRIVATE PUBLIC :: SPEC_VIEW, GRID_VIEW, LS, LG, IVSET_PTR PUBLIC :: LS_COUNT, LG_COUNT, GET_NBLK, GET_NPROMA, GET_NFLD, GET_NSPEC2 TYPE SPEC_VIEW ! Spectral field view REAL(KIND=JPRB),POINTER :: P(:) => NULL() CHARACTER(LEN=:),POINTER :: NAME => NULL() END TYPE TYPE GRID_VIEW ! Grid point field view REAL(KIND=JPRB),POINTER :: P(:,:) => NULL() CHARACTER(LEN=:), POINTER :: NAME => NULL() INTEGER(KIND=JPIM) :: IVSET END TYPE TYPE IVSET_PTR INTEGER(KIND=JPIM), POINTER :: PTR(:) => NULL() INTEGER(KIND=JPIM) :: BASE = 1 END TYPE INTERFACE GET_NFLD MODULE PROCEDURE :: GET_NFLD_1, GET_NFLD_3 END INTERFACE INTERFACE GET_NPROMA MODULE PROCEDURE :: GET_NPROMA_1, GET_NPROMA_2, GET_NPROMA_3 END INTERFACE INTERFACE GET_NBLK MODULE PROCEDURE :: GET_NBLK_1, GET_NBLK_2, GET_NBLK_3 END INTERFACE INTERFACE GET_NSPEC2 MODULE PROCEDURE :: GET_NSPEC2_1, GET_NSPEC2_2, GET_NSPEC2_3 END INTERFACE CONTAINS SUBROUTINE TO_STR(I, STR_OUT) INTEGER, INTENT(IN) :: I CHARACTER(LEN=*), INTENT(OUT) :: STR_OUT WRITE(STR_OUT, '(I0)') I END SUBROUTINE TO_STR SUBROUTINE ASSERT_DIM_ROLE(YLF, FORTRAN_DIM, EXPECTED_ROLE, ROUTINE) TYPE(FIELD_VIEW), INTENT(IN) :: YLF INTEGER, INTENT(IN) :: FORTRAN_DIM, EXPECTED_ROLE CHARACTER(LEN=*), INTENT(IN) :: ROUTINE IF (FIELD_VIEW_GET_DIM_ROLE(YLF, FORTRAN_DIM) /= EXPECTED_ROLE) THEN CALL ABORT_TRANS(ROUTINE // " FAILURE: FIELD_VIEW DIMENSION ROLE MISMATCH") ENDIF END SUBROUTINE SUBROUTINE PROCESS_NPROMA(LIST, NPROMA) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM), INTENT(INOUT) :: NPROMA INTEGER :: I INTEGER(JPIM) :: FIELD_NPROMA DO I = 1, SIZE(LIST) FIELD_NPROMA = FIELD_VIEW_GET_EXTENT_BY_ROLE(LIST(I), FIELD_VIEW_DIM_ROLE%NPROMA) IF (FIELD_NPROMA == 0) FIELD_NPROMA = 1 IF (NPROMA == 0) THEN NPROMA = FIELD_NPROMA ELSE IF (NPROMA /= FIELD_NPROMA) THEN CALL ABORT_TRANS("GET_NPROMA FAILURE: Inconsistent NPROMA values across fields") ENDIF ENDDO END SUBROUTINE FUNCTION GET_NPROMA_1(LIST) RESULT(NPROMA) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM) :: NPROMA NPROMA = 0 CALL PROCESS_NPROMA(LIST, NPROMA) END FUNCTION FUNCTION GET_NPROMA_2(LIST1, LIST2) RESULT(NPROMA) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:) INTEGER(JPIM) :: NPROMA NPROMA = 0 CALL PROCESS_NPROMA(LIST1, NPROMA) CALL PROCESS_NPROMA(LIST2, NPROMA) END FUNCTION FUNCTION GET_NPROMA_3(LIST1, LIST2, LIST3) RESULT(NPROMA) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:), LIST3(:) INTEGER(JPIM) :: NPROMA NPROMA = 0 CALL PROCESS_NPROMA(LIST1, NPROMA) CALL PROCESS_NPROMA(LIST2, NPROMA) CALL PROCESS_NPROMA(LIST3, NPROMA) END FUNCTION SUBROUTINE PROCESS_NBLK(LIST, NBLK) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM), INTENT(INOUT) :: NBLK INTEGER :: I INTEGER(JPIM) :: FIELD_NBLK DO I = 1, SIZE(LIST) FIELD_NBLK = FIELD_VIEW_GET_EXTENT_BY_ROLE(LIST(I), FIELD_VIEW_DIM_ROLE%BLOCK) IF (NBLK == 0) THEN NBLK = FIELD_NBLK ELSE IF (NBLK /= FIELD_NBLK) THEN CALL ABORT_TRANS("GET_NBLK FAILURE: Inconsistent NBLK values across fields") ENDIF ENDDO END SUBROUTINE FUNCTION GET_NBLK_1(LIST) RESULT(NBLK) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM) :: NBLK NBLK = 0 CALL PROCESS_NBLK(LIST, NBLK) END FUNCTION FUNCTION GET_NBLK_2(LIST1, LIST2) RESULT(NBLK) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:) INTEGER(JPIM) :: NBLK NBLK = 0 CALL PROCESS_NBLK(LIST1, NBLK) CALL PROCESS_NBLK(LIST2, NBLK) END FUNCTION FUNCTION GET_NBLK_3(LIST1, LIST2, LIST3) RESULT(NBLK) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:), LIST3(:) INTEGER(JPIM) :: NBLK NBLK = 0 CALL PROCESS_NBLK(LIST1, NBLK) CALL PROCESS_NBLK(LIST2, NBLK) CALL PROCESS_NBLK(LIST3, NBLK) END FUNCTION SUBROUTINE PROCESS_NFLD(LIST, NFLD) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM), INTENT(INOUT) :: NFLD INTEGER :: I INTEGER(JPIM) :: FIELD_NLEV, FIELD_NFLD DO I = 1, SIZE(LIST) FIELD_NLEV = MAX(FIELD_VIEW_GET_EXTENT_BY_ROLE(LIST(I), FIELD_VIEW_DIM_ROLE%LEVEL), 1) FIELD_NFLD = MAX(FIELD_VIEW_GET_EXTENT_BY_ROLE(LIST(I), FIELD_VIEW_DIM_ROLE%FIELD), 1) NFLD = NFLD + FIELD_NLEV * FIELD_NFLD ENDDO END SUBROUTINE FUNCTION GET_NFLD_1(LIST) RESULT(NFLD) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM) :: NFLD NFLD = 0 CALL PROCESS_NFLD(LIST, NFLD) END FUNCTION FUNCTION GET_NFLD_2(LIST1, LIST2) RESULT(NFLD) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:) INTEGER(JPIM) :: NFLD NFLD = 0 CALL PROCESS_NFLD(LIST1, NFLD) CALL PROCESS_NFLD(LIST2, NFLD) END FUNCTION FUNCTION GET_NFLD_3(LIST1, LIST2, LIST3) RESULT(NFLD) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:), LIST3(:) INTEGER(JPIM) :: NFLD NFLD = 0 CALL PROCESS_NFLD(LIST1, NFLD) CALL PROCESS_NFLD(LIST2, NFLD) CALL PROCESS_NFLD(LIST3, NFLD) END FUNCTION SUBROUTINE PROCESS_NSPEC2(LIST, NSPEC2) ! Return the spectral dimension (NSPEC2) found in LIST. ! Spectral fields follow these shape conventions: ! rank 1: (NSPEC) -> NSPEC2 = EXTENTS(1) ! rank 2: (NLEVS, NSPEC) -> NSPEC2 = EXTENTS(2) ! rank 3: (NLEVS, NSPEC, NFIELDS) -> NSPEC2 = EXTENTS(2) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM), INTENT(INOUT) :: NSPEC2 INTEGER :: I DO I = 1, SIZE(LIST) IF (LIST(I)%RANK == 1) THEN IF (NSPEC2 == 0) THEN NSPEC2 = FIELD_VIEW_GET_EXTENT(LIST(I), 1) ELSE IF (NSPEC2 /= FIELD_VIEW_GET_EXTENT(LIST(I), 1)) THEN CALL ABORT_TRANS("GET_NSPEC2 FAILURE: Inconsistent NSPEC2 values across fields") ENDIF ELSE IF (LIST(I)%RANK == 2 .OR. LIST(I)%RANK == 3) THEN IF (NSPEC2 == 0) THEN NSPEC2 = FIELD_VIEW_GET_EXTENT(LIST(I), 2) ELSE IF (NSPEC2 /= FIELD_VIEW_GET_EXTENT(LIST(I), 2)) THEN CALL ABORT_TRANS("GET_NSPEC2 FAILURE: Inconsistent NSPEC2 values across fields") ENDIF ELSE CALL ABORT_TRANS("GET_NSPEC2 FAILURE: RANK MUST BE <= 3") ENDIF ENDDO END SUBROUTINE FUNCTION GET_NSPEC2_1(LIST) RESULT(NSPEC2) TYPE(FIELD_VIEW), INTENT(IN) :: LIST(:) INTEGER(JPIM) :: NSPEC2 NSPEC2 = 0 CALL PROCESS_NSPEC2(LIST, NSPEC2) END FUNCTION FUNCTION GET_NSPEC2_2(LIST1, LIST2) RESULT(NSPEC2) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:) INTEGER(JPIM) :: NSPEC2 NSPEC2 = 0 CALL PROCESS_NSPEC2(LIST1, NSPEC2) CALL PROCESS_NSPEC2(LIST2, NSPEC2) END FUNCTION FUNCTION GET_NSPEC2_3(LIST1, LIST2, LIST3) RESULT(NSPEC2) TYPE(FIELD_VIEW), INTENT(IN) :: LIST1(:), LIST2(:), LIST3(:) INTEGER(JPIM) :: NSPEC2 NSPEC2 = 0 CALL PROCESS_NSPEC2(LIST1, NSPEC2) CALL PROCESS_NSPEC2(LIST2, NSPEC2) CALL PROCESS_NSPEC2(LIST3, NSPEC2) END FUNCTION FUNCTION LG_COUNT(YLFL) RESULT(IOFF) ! Compute the number of GRID_VIEW that will be generated for a list YLFL of FIELD_VIEW TYPE (FIELD_VIEW),TARGET, INTENT(IN) :: YLFL (:) ! input list of FIELD_VIEW INTEGER(KIND=JPIM) :: IOFF INTEGER(KIND=JPIM) :: ILEN, JFLD IOFF = 0 DO JFLD = 1, SIZE (YLFL) SELECT CASE (YLFL(JFLD)%RANK) CASE (1) ILEN = 1 CASE (2) ILEN = 1 CASE(3) ILEN = FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 2) CASE(4) ILEN = FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 2) * FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 3) CASE DEFAULT CALL ABORT_TRANS("LG FAILURE: CLASS UNKNOWN") END SELECT IOFF = IOFF + ILEN ENDDO END FUNCTION LG_COUNT FUNCTION LS_COUNT(YLFL) RESULT(IOFF) ! Compute the number of SPEC_VIEW that will be generated for a list YLFL of FIELD_VIEW TYPE (FIELD_VIEW), TARGET, INTENT(IN) :: YLFL (:) ! input list of FIELD_VIEW INTEGER(KIND=JPIM) :: IOFF INTEGER(KIND=JPIM) :: ILEN, JFLD IOFF = 0 DO JFLD = 1, SIZE (YLFL) SELECT CASE (YLFL(JFLD)%RANK) CASE (1) ILEN = 1 CASE (2) ! Shape (NLEVS, NSPEC) -> NLEVS SPEC_VIEW of size NSPEC ILEN = FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 1) CASE (3) ! Shape (NLEVS, NSPEC, NFIELDS) -> NLEVS*NFIELDS SPEC_VIEW of size NSPEC ILEN = FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 1) * FIELD_VIEW_GET_EXTENT(YLFL(JFLD), 3) CASE (4) CALL ABORT_TRANS("LS not implemeted for RANK 4") CASE DEFAULT ! Skip the spectral field as it is not present on this processor ILEN = 1 END SELECT IOFF = IOFF + ILEN ENDDO END FUNCTION LS_COUNT SUBROUTINE LG2RB(LG2RBV,YLF,IVSET) ! Creation of a list of GRID_VIEW encapsulating the layer of an input FIELD_VIEW field ! Given YLF dimensioned(NPROMA, NBLKS) as input, ! the output list size will contain one element, its view beeing dimensioned(NPROMA, NBLKS) TYPE (FIELD_VIEW), POINTER, INTENT (IN) :: YLF TYPE (GRID_VIEW), INTENT(INOUT) :: LG2RBV (:) TYPE (IVSET_PTR), INTENT(IN) :: IVSET CHARACTER(LEN=:), POINTER :: CNAME REAL(KIND=JPRB), POINTER :: ZZ2 (:,:) CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%NPROMA, "LG2RB") CALL ASSERT_DIM_ROLE(YLF, 2, FIELD_VIEW_DIM_ROLE%BLOCK, "LG2RB") CALL FIELD_VIEW_GET_DATA_PTR(YLF, ZZ2) CALL FIELD_VIEW_GET_NAME_PTR(YLF, CNAME) IF (SIZE(LG2RBV) /= 1 ) CALL ABORT_TRANS("Error - incorrect size for LG2RBV") LG2RBV(1)%P => ZZ2(:,:) LG2RBV(1)%NAME => CNAME IF (ASSOCIATED(IVSET%PTR)) THEN LG2RBV (1)%IVSET = IVSET%PTR(1) - IVSET%BASE + 1 ELSE LG2RBV (1)%IVSET = 1 ! default value when IVSET is not provided ENDIF END SUBROUTINE LG2RB SUBROUTINE LG3RB(LG3RBV,YLF,IVSET) ! Creation of a list of GRID_VIEW encapsulating the layers of an input FIELD_VIEW field ! Given YLF dimensioned(NPROMA, NLEVS, NBLKS) as input, ! the output list size will contain (NLEVS) elements, their view beeing dimensioned(NPROMA, NBLKS) TYPE (FIELD_VIEW), POINTER, INTENT (IN) :: YLF TYPE (GRID_VIEW), INTENT(INOUT) :: LG3RBV (:) TYPE (IVSET_PTR), INTENT(IN) :: IVSET CHARACTER(LEN=:), POINTER :: CNAME CHARACTER(LEN=16) :: IVSET_SIZE_STR, LEVEL_SIZE_STR REAL(KIND=JPRB), POINTER :: ZZ3 (:,:,:) INTEGER(KIND=JPIM) :: JLEV, JCOUNT CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%NPROMA, "LG3RB") CALL ASSERT_DIM_ROLE(YLF, 2, FIELD_VIEW_DIM_ROLE%LEVEL, "LG3RB") CALL ASSERT_DIM_ROLE(YLF, 3, FIELD_VIEW_DIM_ROLE%BLOCK, "LG3RB") CALL FIELD_VIEW_GET_DATA_PTR(YLF, ZZ3) CALL FIELD_VIEW_GET_NAME_PTR(YLF, CNAME) IF (SIZE(LG3RBV) /= SIZE (ZZ3, 2) ) CALL ABORT_TRANS("Error - incorrect size for LG3RBV") IF (ASSOCIATED(IVSET%PTR)) THEN IF (SIZE(IVSET%PTR) /= SIZE(ZZ3, 2)) THEN CALL TO_STR(SIZE(IVSET%PTR), IVSET_SIZE_STR) CALL TO_STR(SIZE(ZZ3, 2), LEVEL_SIZE_STR) CALL ABORT_TRANS("Error - LG3RB: incorrect size for IVSET: SIZE(IVSET) = " // TRIM(IVSET_SIZE_STR) & // " but SIZE(ZZ3, 2) = " // TRIM(LEVEL_SIZE_STR)) END IF END IF JCOUNT = 1 DO JLEV = LBOUND (ZZ3, 2), UBOUND (ZZ3, 2) LG3RBV (JCOUNT)%P => ZZ3 (:, JLEV, :) LG3RBV(JCOUNT)%NAME => CNAME IF (ASSOCIATED(IVSET%PTR)) THEN LG3RBV (JCOUNT)%IVSET = IVSET%PTR(JLEV) - IVSET%BASE + 1 ELSE LG3RBV (JCOUNT)%IVSET = 1 ! default value when IVSET is not provided ENDIF JCOUNT = JCOUNT + 1 ENDDO END SUBROUTINE LG3RB SUBROUTINE LG4RB(LG4RBV, YLF, IVSET) ! Creation of a list of GRID_VIEW encapsulating the layers of an input FIELD_VIEW field ! Given YLF dimensioned(NPROMA, NLEVS, NFIELDS, NBLKS) as input, ! the output list size will contain (NLEVS*NFIELDS) elementa, their view beeing dimensioned(NPROMA, NBLKS) TYPE (FIELD_VIEW), INTENT(IN), POINTER :: YLF TYPE (GRID_VIEW), INTENT(INOUT) :: LG4RBV (:) TYPE (IVSET_PTR), INTENT(IN) :: IVSET CHARACTER(LEN=:), POINTER :: CNAME CHARACTER(LEN=16) :: IVSET_SIZE_STR, LEVEL_SIZE_STR REAL(KIND=JPRB), POINTER :: ZZ4 (:,:,:,:) INTEGER(KIND=JPIM) :: JLEV, JFLD, JCOUNT CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%NPROMA, "LG4RB") CALL ASSERT_DIM_ROLE(YLF, 2, FIELD_VIEW_DIM_ROLE%LEVEL, "LG4RB") CALL ASSERT_DIM_ROLE(YLF, 3, FIELD_VIEW_DIM_ROLE%FIELD, "LG4RB") CALL ASSERT_DIM_ROLE(YLF, 4, FIELD_VIEW_DIM_ROLE%BLOCK, "LG4RB") CALL FIELD_VIEW_GET_DATA_PTR(YLF, ZZ4) CALL FIELD_VIEW_GET_NAME_PTR(YLF, CNAME) IF (SIZE(LG4RBV) /= SIZE (ZZ4, 2) * SIZE (ZZ4, 3) ) CALL ABORT_TRANS("Error - incorrect size for LG4RBV") IF (ASSOCIATED(IVSET%PTR)) THEN IF (SIZE(IVSET%PTR) /= SIZE(ZZ4, 2)) THEN CALL TO_STR(SIZE(IVSET%PTR), IVSET_SIZE_STR) CALL TO_STR(SIZE(ZZ4, 2), LEVEL_SIZE_STR) CALL ABORT_TRANS("Error - LG4RB: incorrect size for IVSET: SIZE(IVSET) = " // TRIM(IVSET_SIZE_STR) & // " but SIZE(ZZ4, 2) = " // TRIM(LEVEL_SIZE_STR)) END IF END IF JCOUNT = 1 DO JFLD = LBOUND (ZZ4, 3), UBOUND (ZZ4, 3) DO JLEV = LBOUND (ZZ4, 2), UBOUND (ZZ4, 2) LG4RBV(JCOUNT)%P => ZZ4(:, JLEV, JFLD, :) LG4RBV(JCOUNT)%NAME => CNAME IF (ASSOCIATED(IVSET%PTR)) THEN LG4RBV (JCOUNT)%IVSET = IVSET%PTR(JLEV) - IVSET%BASE + 1 ELSE LG4RBV (JCOUNT)%IVSET = 1 ! default value when IVSET is not provided ENDIF JCOUNT = JCOUNT + 1 ENDDO ENDDO END SUBROUTINE LG4RB SUBROUTINE LG(YLFL,LGV,IVSET) ! Creation of a list of GRID_VIEW from a list YLFL of FIELD_VIEW ! For each field of YLFL, the IVSET of the matching spectral field can be provided ! through the optional IVSET argument. If IVSET is not provided, the IVSET of the ! generated GRID_VIEW is set to a default value (1). TYPE (FIELD_VIEW),TARGET, INTENT(IN) :: YLFL (:) ! input list of FIELD_VIEW TYPE (GRID_VIEW), INTENT(INOUT) :: LGV (:) ! output list of GRID_VIEW TYPE (IVSET_PTR), INTENT(IN), OPTIONAL :: IVSET(:) TYPE (FIELD_VIEW), POINTER:: YLF TYPE (IVSET_PTR) :: IVSET_NULL INTEGER(KIND=JPIM) :: IOFF INTEGER(KIND=JPIM) :: ILEN, JFLD IF (PRESENT(IVSET)) THEN IF (SIZE(YLFL) /= SIZE(IVSET)) CALL ABORT_TRANS("LG FAILURE: SIZE(YLFL) /= SIZE(IVSET)") ENDIF IOFF = 0 ILEN = -1 ! iterate over YLFL LIST DO JFLD = 1, SIZE (YLFL) ! compute number of GRID_VIEW that will be generated for each field of the list ! In addition if LGV_PROVIDED: call the correct routine to create the GRID_VIEW for each field of the list YLF => YLFL (JFLD) SELECT CASE (YLF%RANK) CASE (1) ILEN = 1 CASE (2) ILEN = 1 IF (PRESENT(IVSET)) THEN CALL LG2RB(LGV(IOFF+1:IOFF+ILEN),YLF,IVSET(JFLD)) ELSE CALL LG2RB(LGV(IOFF+1:IOFF+ILEN),YLF,IVSET_NULL) ENDIF CASE(3) ILEN = FIELD_VIEW_GET_EXTENT(YLF, 2) IF (PRESENT(IVSET)) THEN CALL LG3RB(LGV (IOFF+1:IOFF+ILEN),YLF,IVSET(JFLD)) ELSE CALL LG3RB(LGV (IOFF+1:IOFF+ILEN),YLF,IVSET_NULL) ENDIF CASE(4) ILEN = FIELD_VIEW_GET_EXTENT(YLF, 2) * FIELD_VIEW_GET_EXTENT(YLF, 3) IF (PRESENT(IVSET)) THEN CALL LG4RB(LGV (IOFF+1:IOFF+ILEN),YLF,IVSET(JFLD)) ELSE CALL LG4RB(LGV (IOFF+1:IOFF+ILEN),YLF,IVSET_NULL) ENDIF CASE DEFAULT CALL ABORT_TRANS("LG FAILURE: CLASS UNKNOWN") END SELECT IOFF = IOFF + ILEN ENDDO IF (SIZE(LGV) /= IOFF) CALL ABORT_TRANS("LG FAILURE: LGV has incorrect size") END SUBROUTINE LG SUBROUTINE LS1RB(LS1RBV, YLF) ! Creation of a list of SPEC_VIEW encapsulating the layer of an input FIELD_1RB field ! Given YLF dimensioned(NSPEC) as input, ! the output list size will contain one element, its view beeing dimensioned(NSPEC) TYPE (FIELD_VIEW), POINTER, INTENT (IN) :: YLF TYPE (SPEC_VIEW), INTENT(INOUT) :: LS1RBV (:) CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%SPEC2, "LS1RB") IF (SIZE(LS1RBV) /= 1 ) CALL ABORT_TRANS("Error - incorrect size for LS1RBV") CALL FIELD_VIEW_GET_DATA_PTR(YLF, LS1RBV(1)%P) CALL FIELD_VIEW_GET_NAME_PTR(YLF,LS1RBV(1)%NAME) END SUBROUTINE LS1RB SUBROUTINE LS2RB(LS2RBV,YLF) ! Creation of a list of SPEC_VIEW, each of them encapsulating a layer of an input FIELD_VIEW field. ! Given YLF dimensioned(NLEVS, NSPEC) as input, ! the output list size will contain (NLEVS) elements dimensioned(NSPEC) TYPE (FIELD_VIEW), POINTER, INTENT (IN) :: YLF TYPE (SPEC_VIEW), INTENT(INOUT) :: LS2RBV (:) REAL(KIND=JPRB), POINTER :: ZZ2 (:,:) CHARACTER(LEN=:), POINTER :: CNAME INTEGER(KIND=JPIM) :: JLEV, JCOUNT CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%LEVEL, "LS2RB") CALL ASSERT_DIM_ROLE(YLF, 2, FIELD_VIEW_DIM_ROLE%SPEC2, "LS2RB") CALL FIELD_VIEW_GET_DATA_PTR(YLF, ZZ2) CALL FIELD_VIEW_GET_NAME_PTR(YLF,CNAME) IF (SIZE(LS2RBV) /= SIZE (ZZ2, 1) ) CALL ABORT_TRANS("Error - incorrect size for LS2RBV") JCOUNT = 1 DO JLEV = LBOUND (ZZ2, 1), UBOUND (ZZ2, 1) LS2RBV(JCOUNT)%P => ZZ2 (JLEV, :) LS2RBV(JCOUNT)%NAME => CNAME JCOUNT = JCOUNT + 1 ENDDO END SUBROUTINE LS2RB SUBROUTINE LS3RB(LS3RBV,YLF) ! Creation of a list of SPEC_VIEW, each of them encapsulating a layer of an input FIELD_VIEW field. ! Given YLF dimensioned(NLEVS, NSPEC, NFIELDS) as input, ! the output list size will contain (NLEVS*NFIELDS) SPEC_VIEW, each of them dimensioned(NSPEC) TYPE (FIELD_VIEW), POINTER, INTENT (IN) :: YLF TYPE (SPEC_VIEW), INTENT(INOUT) :: LS3RBV (:) REAL(KIND=JPRB), POINTER :: ZZ3 (:,:,:) CHARACTER(LEN=:), POINTER :: CNAME INTEGER(KIND=JPIM) :: JLEV, JFLD, JCOUNT CALL ASSERT_DIM_ROLE(YLF, 1, FIELD_VIEW_DIM_ROLE%LEVEL, "LS3RB") CALL ASSERT_DIM_ROLE(YLF, 2, FIELD_VIEW_DIM_ROLE%SPEC2, "LS3RB") CALL ASSERT_DIM_ROLE(YLF, 3, FIELD_VIEW_DIM_ROLE%FIELD, "LS3RB") CALL FIELD_VIEW_GET_DATA_PTR(YLF, ZZ3) CALL FIELD_VIEW_GET_NAME_PTR(YLF,CNAME) IF (SIZE(LS3RBV) /=SIZE (ZZ3, 1) * SIZE (ZZ3, 3) ) CALL ABORT_TRANS("Error - incorrect size for LS3RBV") JCOUNT = 1 DO JFLD = LBOUND (ZZ3, 3), UBOUND (ZZ3, 3) DO JLEV = LBOUND (ZZ3, 1), UBOUND (ZZ3, 1) LS3RBV(JCOUNT)%P => ZZ3 (JLEV, :, JFLD) LS3RBV(JCOUNT)%NAME => CNAME JCOUNT = JCOUNT + 1 ENDDO ENDDO END SUBROUTINE LS3RB SUBROUTINE LS(YLFL,LSV) ! Creation of a list of SPEC_VIEW from a list YLFL of FIELD_BASIC_PTR TYPE (FIELD_VIEW), TARGET, INTENT(IN) :: YLFL (:) ! input list of FIELD_BASIC_PTR TYPE (SPEC_VIEW), INTENT(INOUT) :: LSV (:) ! output list of SPEC_VIEW INTEGER(KIND=JPIM) :: IOFF INTEGER(KIND=JPIM) :: ILEN, JFLD TYPE (FIELD_VIEW), POINTER:: YLF REAL(KIND=JPRB), POINTER :: ZZ1 (:) IOFF = 0 ILEN = -1 ! iterate over YLFL LIST DO JFLD = 1, SIZE (YLFL) ! compute number of SPEC_VIEW that will be generated for each field of the list ! in addition when LSV_PROVIDED: call the correct routine to create the SPEC_VIEW for each field of the list YLF => YLFL (JFLD) SELECT CASE (YLF%RANK) CASE (1) ILEN = 1 CALL LS1RB(LSV(IOFF+1:IOFF+ILEN),YLF) CASE (2) ! Shape (NLEVS, NSPEC) -> NLEVS SPEC_VIEW of size NSPEC ILEN = FIELD_VIEW_GET_EXTENT(YLF, 1) CALL LS2RB(LSV(IOFF+1:IOFF+ILEN),YLF) CASE (3) ! Shape (NLEVS, NSPEC, NFIELDS) -> NLEVS*NFIELDS SPEC_VIEW of size NSPEC ILEN = FIELD_VIEW_GET_EXTENT(YLF, 1) * FIELD_VIEW_GET_EXTENT(YLF, 3) CALL LS3RB(LSV(IOFF+1:IOFF+ILEN),YLF) CASE (4) CALL ABORT_TRANS("LS not implemeted for RANK 4") CASE DEFAULT ! Skip the spectral field as it is not present on this processor ILEN = 1 END SELECT IOFF = IOFF + ILEN ENDDO IF (SIZE(LSV) /= IOFF) CALL ABORT_TRANS("LS FAILURE: LSV has incorrect size") END SUBROUTINE LS END MODULE