! (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 EFTDIR_CTLAD_MOD CONTAINS SUBROUTINE EFTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB, & & KVSETUV,KVSETSC,KPTRGP,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *EFTDIR_CTLAD - Direct Fourier transform control - adjoint ! Purpose. Control routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL EFTDIR_CTLAD(..) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! PGP - gridpoint array ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fields in gridpoint space ! Method. ! ------- ! Externals. TRGTOL - transposition routine ! ---------- FOURIER_OUT - copy fourier data to Fourier buffer ! EFTDIRAD - fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! 19-11-01 G. Radnoti bug correction by introducing CPL_INT interface ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 05-03-15 remove HLOMP ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D USE TRLTOG_MOD ,ONLY : TRLTOG USE FOURIER_OUTAD_MOD ,ONLY : FOURIER_OUTAD USE EFTDIRAD_MOD ,ONLY : EFTDIRAD ! IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) ! Local variables REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: JGL,IGL,J1,J2 INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Field distribution in Spectral/Fourier space IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',0,ZHOOK_HANDLE) CALL GSTATS(133,0) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ZGTF => ZGTF_HEAP(:,:) ENDIF ZGTF(:,:)=0._JPRB IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IVSETSC(:) = -1 ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF CALL GSTATS(1642,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL=1,D%NDGL_FS IGL = JGL CALL FOURIER_OUTAD(ZGTF,KF_FS,IGL) ! Fourier transform IF(KF_FS>0) THEN CALL EFTDIRAD(ZGTF,KF_FS,IGL) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1642,1) CALL GSTATS(133,1) ! Transposition CALL GSTATS(183,0) IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:) = -1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) DO J3=1,UBOUND(PGP3A,3) IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) DO J3=1,UBOUND(PGP3B,3) IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(183,1) IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTDIR_CTLAD END MODULE EFTDIR_CTLAD_MOD