! (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. ! SUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) !**** *EGATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL EGATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set to zero imaginary part of first coefficients ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 ! R. El Khatib 23-Oct-2012 Monkey business ! P.Marguinaud 10-Oct-2013 Add an option to set (or not) first ! coefficients imaginary part to zero ! R. El Khatib 01-Dec-2020 Merge egath_spec_control and gath_spec_control ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC USE TPMALD_DISTR USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, IMSMAX, ISPEC2, ISPEC2_G,ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL ESET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KTO TOO SHORT!') ENDIF ISMAX = R%NSMAX IMSMAX = RALD%NMSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX IF(PRESENT(KMSMAX)) IMSMAX = KMSMAX ALLOCATE(IDIM0G(0:IMSMAX)) ALLOCATE(IALLMS(IMSMAX+1)) ALLOCATE(IKN(0:IMSMAX)) IF(IMSMAX /= RALD%NMSMAX .OR. ISMAX /= R%NSMAX) THEN CALL ABORT_TRANS('EGATH_SPEC:TRUNCATION CHANGE NOT YET CODED') ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) DO J=0,IMSMAX IKN(J)=2*DALD%NCPL2M(J) ENDDO ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'EGATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('EGATH_SPEC:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('EGATH_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN WRITE(NERR,*) 'EGATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV CALL ABORT_TRANS('EGATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'EGATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('EGATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFGATHG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFSEND = IFSEND+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFGATHG) ELSEIF(NPRTRV > 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET MISSING, NPRTRV > 1') ELSE IFSEND = KFGATHG IVSET(:) = 1 ENDIF IF(IFSEND > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('EGATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& & IMSMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC