! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- 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 DIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSMAX,KSORT) !**** *DIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing 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 ! KSORT (:) - Re-order fields on output ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! P.Marguinaud : 10-10-14 Add KSORT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL USE SUWAVEDI_MOD ,ONLY : SUWAVEDI 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(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFDISTG) INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J,IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_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(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KFROM TOO SHORT!') ENDIF ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& & KDIM0G=IDIM0G) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_SPEC:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('DIST_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN WRITE(NERR,*) 'DIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND CALL ABORT_TRANS('DIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'DIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('DIST_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFDISTG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'DIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('DIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFRECV = IFRECV+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFDISTG) ELSE IFRECV = KFDISTG IVSET(:) = MYSETV ENDIF IF(IFRECV > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN CALL ABORT_TRANS('DIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('DIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (.NOT. PRESENT (PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: KSORT REQUIRES PSPEC') ENDIF IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN CALL ABORT_TRANS('DIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') ENDIF ENDIF CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,KSORT) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('DIST_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC