! (C) Copyright 2026- ECMWF. ! (C) Copyright 2026- 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. ! SUBROUTINE DIR_TRANS_FIELD_VIEW(KRESOL, & & YDGPSCALAR, YDGPU, YDGPV, & & YDSPSCALAR, YDSPVOR, YDSPDIV) USE ISO_FORTRAN_ENV, ONLY : INT32 USE ECTRANS_FIELD_VIEW_MOD, ONLY: FIELD_VIEW USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE PARKIND1 ,ONLY : JPRB, JPIM USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS USE ECTRANS_FIELD_VIEW_MOD, ONLY: FIELD_VIEW_GET_IVSET_PTR USE ECTRANS_FIELD_VIEW_INTERNAL_UTIL_MOD, ONLY: SPEC_VIEW, GRID_VIEW, LS_COUNT, LG_COUNT, LS, LG, IVSET_PTR, & & GET_NPROMA, GET_NFLD, GET_NSPEC2, GET_NBLK IMPLICIT NONE ! Arguments ! INPUT INTEGER(KIND=INT32), INTENT(IN) :: KRESOL TYPE(FIELD_VIEW), INTENT(IN) :: YDGPSCALAR(:), YDGPU(:), YDGPV(:) ! OUTPUT (note that views have intent(IN), i.e. the view itself is immutable, not the data) TYPE(FIELD_VIEW), INTENT(IN) :: YDSPSCALAR(:), YDSPVOR(:), YDSPDIV(:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: NFIELD_UV, NFIELD_SCALAR INTEGER(KIND=JPIM) :: NPROMA, NBLK, NFIELD_TOTAL_UV, NSPEC2 ! Local variables ! Lists of SPEC_VIEW and GRID_VIEW: intermediate representation of fields to facilitate copy to temporary arrays TYPE(SPEC_VIEW), ALLOCATABLE :: YLSPVSCALAR(:) TYPE(SPEC_VIEW), ALLOCATABLE :: YLSPVVOR(:), YLSPVDIV(:) TYPE(GRID_VIEW), ALLOCATABLE :: YLGVSCALAR(:) TYPE(GRID_VIEW), ALLOCATABLE :: YLGVU(:),YLGVV(:) ! Temporary arrays for dir_trans REAL(KIND=JPRB),POINTER :: ZPSPVOR(:,:),ZPSPDIV(:,:) ! spectral vector fields (out) REAL(KIND=JPRB),POINTER :: ZPSPSC2(:,:) ! spectral scalar fields(out) REAL(KIND=JPRB),POINTER :: ZPGPUV(:,:,:,:) ! grid vector fields (in) REAL(KIND=JPRB),POINTER :: ZPGP2(:,:,:) ! grid scalar fields (in) REAL(KIND=JPRB), POINTER :: ZZ1_1(:) REAL(KIND=JPRB), POINTER :: ZZ1_2(:) REAL(KIND=JPRB), POINTER :: ZZ2_1(:,:) REAL(KIND=JPRB), POINTER :: ZZ2_2(:,:) ! b-set for dir-trans INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETUV(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETSC2(:) TYPE(IVSET_PTR), ALLOCATABLE :: IVSETUV_LIST(:) TYPE(IVSET_PTR), ALLOCATABLE :: IVSETSC_LIST(:) INTEGER(KIND=JPIM) :: IFLDXG INTEGER(KIND=JPIM) :: IFLDXL INTEGER(KIND=JPIM) :: IFLDSPVOR INTEGER(KIND=JPIM) :: IFLDSPSC INTEGER(KIND=JPIM) :: IUVG INTEGER(KIND=JPIM) :: IUVDIM INTEGER(KIND=JPIM) :: ID INTEGER(KIND=JPIM) :: IOFFSET INTEGER(KIND=JPIM) :: JLEV ! Level counter INTEGER(KIND=JPIM) :: JFLD ! Field counter INTEGER(KIND=JPIM) :: KFLEVG #include "dir_trans.h" IF (LHOOK) CALL DR_HOOK('DIR_TRANS_FIELD_VIEW',0,ZHOOK_HANDLE) NFIELD_UV = SIZE(YDGPU) NFIELD_SCALAR = SIZE(YDGPSCALAR) NPROMA = GET_NPROMA(YDGPU, YDGPV, YDGPSCALAR) NBLK = GET_NBLK(YDGPU, YDGPV, YDGPSCALAR) NFIELD_TOTAL_UV = GET_NFLD(YDGPU) NSPEC2 = GET_NSPEC2(YDSPVOR, YDSPDIV, YDSPSCALAR) IFLDXG = 0 IFLDXL = 0 IFLDSPVOR= 0 IFLDSPSC= 0 IUVG = 0 JFLD = 0 IUVDIM = 0 ID = 0 IOFFSET = 0 JLEV = 0 JFLD = 0 ! 1. Vector fields transformation to spectral space ! Preliminary checks ! Do we have vector fields? IF (SIZE(YDGPU) > 0) THEN IF ((SIZE(YDGPU) /= SIZE(YDGPV)).OR.(SIZE(YDGPU) /= SIZE(YDSPDIV)).OR.(SIZE(YDGPU)/= SIZE(YDSPVOR))) THEN CALL ABORT_TRANS("[DIR_TRANS_FIELD_VIEW] The vector arrays have inconsistent sizes: YDGPU, YDGPV, YDSPDIV, YDSPVOR") ENDIF ! Convert list of spectral vector fields into a list of 2d SPEC_VIEW IFLDSPVOR = LS_COUNT(YDSPVOR) ALLOCATE(YLSPVVOR(IFLDSPVOR)) ALLOCATE(YLSPVDIV(IFLDSPVOR)) ! Convert list of grid-point vector fields into a list of 2d GRID_VIEW ALLOCATE(YLGVU(LG_COUNT(YDGPU))) ALLOCATE(YLGVV(LG_COUNT(YDGPV))) IF ((SIZE (YLGVU) /= SIZE (YLGVV)) .OR. (SIZE (YLSPVVOR) /= SIZE (YLSPVDIV))) THEN CALL ABORT_TRANS("[DIR_TRANS_FIELD_VIEW] inconsistent number of field_view for vectors") ENDIF KFLEVG = SIZE (YLGVU) / SIZE (YDGPU) IUVG = SIZE(YDGPU) IUVDIM = 2 ! allocate temporary vector field arrays in spectral space ALLOCATE(ZPSPVOR(IFLDSPVOR,NSPEC2)) ALLOCATE(ZPSPDIV(IFLDSPVOR,NSPEC2)) ! allocate temporary vector field array in grid space ALLOCATE(ZPGPUV(NPROMA,KFLEVG, IUVG * IUVDIM,NBLK)) ! For LG we need the ivset of each grid point field, ! so we extract a matching list from the spectral fields. ALLOCATE(IVSETUV_LIST(IUVG)) DO JFLD=1,IUVG CALL FIELD_VIEW_GET_IVSET_PTR(YDSPVOR(JFLD), IVSETUV_LIST(JFLD)%PTR) IVSETUV_LIST(JFLD)%BASE = YDSPVOR(JFLD)%IVSET_BASE ENDDO CALL LG(YDGPU, YLGVU, IVSETUV_LIST) CALL LG(YDGPV, YLGVV, IVSETUV_LIST) ! Copy list of 2d views of grid point vector fields into temporary arrays IOFFSET = 0 DO JFLD=1,IUVG DO JLEV=1,KFLEVG ID = JLEV + (JFLD -1) * KFLEVG ZZ2_1=>YLGVU(ID)%P ZZ2_2=>YLGVV(ID)%P ZPGPUV(:,JLEV,JFLD+IOFFSET*IUVG,:) = ZZ2_1(:,:) ZPGPUV(:,JLEV,JFLD+(IOFFSET+1)*IUVG,:) = ZZ2_2(:,:) ENDDO ENDDO ALLOCATE(IVSETUV(KFLEVG)) DO JFLD=1,IUVG DO JLEV=1,KFLEVG ID = JLEV + (JFLD -1) * KFLEVG IF (JFLD .EQ. 1) THEN IVSETUV(JLEV) = YLGVU(ID)%IVSET ENDIF IF (IVSETUV(JLEV) .NE. YLGVV(ID)%IVSET) CALL ABORT_TRANS("[DIR_TRANS_FIELD_VIEW] ivsetuv inconsistent with ylgvv%ivset") ENDDO ENDDO ELSE ! No vector field provided IUVG = 0 ZPGPUV=>NULL() ZPSPVOR=>NULL() ZPSPDIV=>NULL() ENDIF ! 2. scalar fields transformation ! Preliminary checks ! Do we have scalar fields? IF (SIZE(YDSPSCALAR) > 0 ) THEN IF ((SIZE(YDSPSCALAR)/= SIZE(YDGPSCALAR))) CALL ABORT_TRANS("[DIR_TRANS_FIELD_VIEW] Inconsistent size & & for YDSPSCALAR and YDGPSCALAR") ! Convert list of spectral scalar fields of any dimension into a list of 2d fields ALLOCATE(YLGVSCALAR(LG_COUNT(YDGPSCALAR))) IFLDXG = SIZE(YLGVSCALAR) IFLDSPSC = LS_COUNT(YDSPSCALAR) ALLOCATE(YLSPVSCALAR(IFLDSPSC)) ! count the number of fields present on the processor CALL LS(YDSPSCALAR, YLSPVSCALAR) IFLDXL = 0 DO JFLD = 1, IFLDSPSC IF (ASSOCIATED(YLSPVSCALAR(JFLD)%P)) IFLDXL = IFLDXL + 1 END DO ! Allocate temporary scalar field array in spectral space ALLOCATE(ZPSPSC2(IFLDXL,NSPEC2)) ! Allocate temporary scalar field array in grid space ALLOCATE(ZPGP2(NPROMA,IFLDXG,NBLK)) ! For LG we need the ivset of each grid point field, ! so we extract a matching list from the spectral fields ALLOCATE(IVSETSC_LIST(SIZE(YDSPSCALAR))) DO JFLD=1,SIZE(YDSPSCALAR) CALL FIELD_VIEW_GET_IVSET_PTR(YDSPSCALAR(JFLD), IVSETSC_LIST(JFLD)%PTR) IVSETSC_LIST(JFLD)%BASE = YDSPSCALAR(JFLD)%IVSET_BASE ENDDO ! Copy list of scalar fields into temporary arrays (2d copy thanks to field_view) CALL LG(YDGPSCALAR, YLGVSCALAR, IVSETSC_LIST) ALLOCATE(IVSETSC2(IFLDXG)) DO JFLD=1, IFLDXG ZZ2_1=>YLGVSCALAR(JFLD)%P ZPGP2(:,JFLD,:) = ZZ2_1(:,:) IVSETSC2(JFLD) = YLGVSCALAR(JFLD)%IVSET ENDDO ELSE !No scalar field provided IFLDXG = 0 ZPGP2=>NULL() ZPSPSC2=>NULL() ENDIF ! 3. CALL DIR_TRANS using the regular interface and the temporary arrays ! We have to perform separated calls for nvfortran IF (ASSOCIATED(ZPGP2) .AND. ASSOCIATED(ZPGPUV)) THEN CALL DIR_TRANS(PSPVOR = ZPSPVOR,PSPDIV = ZPSPDIV,PGPUV = ZPGPUV,KVSETUV = IVSETUV, & & PSPSC2 = ZPSPSC2,PGP2 = ZPGP2, KVSETSC2 = IVSETSC2, & & KPROMA = NPROMA, KRESOL = KRESOL) ELSE IF (ASSOCIATED(ZPGP2)) THEN CALL DIR_TRANS(PSPSC2 = ZPSPSC2,PGP2 = ZPGP2, KVSETSC2 = IVSETSC2, & & KPROMA = NPROMA, KRESOL = KRESOL) ELSE IF (ASSOCIATED(ZPGPUV)) THEN CALL DIR_TRANS(PSPVOR = ZPSPVOR,PSPDIV = ZPSPDIV,PGPUV = ZPGPUV,KVSETUV = IVSETUV, & & KPROMA = NPROMA, KRESOL = KRESOL) ENDIF ! 4. Copy back temporary array data into spectral fields ! copy spectral vorticity and divergence IF (IUVG>0) THEN CALL LS(YDSPVOR, YLSPVVOR) CALL LS(YDSPDIV, YLSPVDIV) DO JFLD=1,IFLDSPVOR IF (ASSOCIATED(YLSPVVOR(JFLD)%P)) THEN ZZ1_1=>YLSPVVOR(JFLD)%P ZZ1_2=>YLSPVDIV(JFLD)%P ZZ1_1(:) = ZPSPVOR(JFLD,:) ZZ1_2(:) = ZPSPDIV(JFLD,:) ENDIF ENDDO ENDIF ! copy spectral scalar fields IF (IFLDSPSC > 0) THEN CALL LS(YDSPSCALAR, YLSPVSCALAR) ID = 1 DO JFLD = 1, IFLDSPSC IF (ASSOCIATED(YLSPVSCALAR(JFLD)%P)) THEN ZZ1_1=>YLSPVSCALAR(JFLD)%P ZZ1_1(:) = ZPSPSC2(ID,:) ID = ID + 1 ENDIF ENDDO ENDIF ! 5. Final cleanup ! delete temporary arrays IF (ASSOCIATED(ZPSPVOR)) DEALLOCATE(ZPSPVOR) IF (ASSOCIATED(ZPSPDIV)) DEALLOCATE(ZPSPDIV) IF (ASSOCIATED(ZPSPSC2)) DEALLOCATE(ZPSPSC2) IF (ASSOCIATED(ZPGPUV)) DEALLOCATE(ZPGPUV) IF (ASSOCIATED(ZPGP2)) DEALLOCATE(ZPGP2) IF (ALLOCATED(IVSETUV)) DEALLOCATE(IVSETUV) IF (ALLOCATED(IVSETSC2)) DEALLOCATE(IVSETSC2) IF (ALLOCATED(IVSETUV_LIST)) DEALLOCATE(IVSETUV_LIST) IF (ALLOCATED(IVSETSC_LIST)) DEALLOCATE(IVSETSC_LIST) ! delete GRID_VIEWS and SPEC_VIEWS IF (ALLOCATED(YLSPVVOR)) DEALLOCATE(YLSPVVOR) IF (ALLOCATED(YLSPVDIV)) DEALLOCATE(YLSPVDIV) IF (ALLOCATED(YLSPVSCALAR)) DEALLOCATE(YLSPVSCALAR) IF (ALLOCATED(YLGVU)) DEALLOCATE(YLGVU) IF (ALLOCATED(YLGVV)) DEALLOCATE(YLGVV) IF (ALLOCATED(YLGVSCALAR)) DEALLOCATE(YLGVSCALAR) IF (LHOOK) CALL DR_HOOK('DIR_TRANS_FIELD_VIEW',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE DIR_TRANS_FIELD_VIEW