dist_spec.F90 Source File


This file depends on

sourcefile~~dist_spec.f90~~EfferentGraph sourcefile~dist_spec.f90 dist_spec.F90 sourcefile~abort_trans_mod.f90 abort_trans_mod.F90 sourcefile~dist_spec.f90->sourcefile~abort_trans_mod.f90 sourcefile~dist_spec_control_mod.f90 dist_spec_control_mod.F90 sourcefile~dist_spec.f90->sourcefile~dist_spec_control_mod.f90 sourcefile~set_resol_mod.f90 set_resol_mod.F90 sourcefile~dist_spec.f90->sourcefile~set_resol_mod.f90 sourcefile~suwavedi_mod.f90 suwavedi_mod.F90 sourcefile~dist_spec.f90->sourcefile~suwavedi_mod.f90 sourcefile~tpm_dim.f90 tpm_dim.F90 sourcefile~dist_spec.f90->sourcefile~tpm_dim.f90 sourcefile~tpm_distr.f90 tpm_distr.F90 sourcefile~dist_spec.f90->sourcefile~tpm_distr.f90 sourcefile~tpm_gen.f90 tpm_gen.F90 sourcefile~dist_spec.f90->sourcefile~tpm_gen.f90 sourcefile~abort_trans_mod.f90->sourcefile~tpm_distr.f90 sourcefile~abort_trans_mod.f90->sourcefile~tpm_gen.f90 sourcefile~dist_spec_control_mod.f90->sourcefile~abort_trans_mod.f90 sourcefile~dist_spec_control_mod.f90->sourcefile~tpm_distr.f90 sourcefile~set2pe_mod.f90 set2pe_mod.F90 sourcefile~dist_spec_control_mod.f90->sourcefile~set2pe_mod.f90 sourcefile~set_resol_mod.f90->sourcefile~abort_trans_mod.f90 sourcefile~set_resol_mod.f90->sourcefile~tpm_dim.f90 sourcefile~set_resol_mod.f90->sourcefile~tpm_distr.f90 sourcefile~set_resol_mod.f90->sourcefile~tpm_gen.f90 sourcefile~tpm_ctl.f90 tpm_ctl.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_ctl.f90 sourcefile~tpm_fft.f90 tpm_fft.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_fft.f90 sourcefile~tpm_fields.f90 tpm_fields.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_fields.f90 sourcefile~tpm_flt.f90 tpm_flt.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_flt.f90 sourcefile~tpm_geometry.f90 tpm_geometry.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_geometry.f90 sourcefile~tpm_hicfft.f90 tpm_hicfft.F90 sourcefile~set_resol_mod.f90->sourcefile~tpm_hicfft.f90 sourcefile~parkind_ectrans.f90 parkind_ectrans.F90 sourcefile~tpm_gen.f90->sourcefile~parkind_ectrans.f90 sourcefile~set2pe_mod.f90->sourcefile~abort_trans_mod.f90 sourcefile~set2pe_mod.f90->sourcefile~tpm_distr.f90 sourcefile~eq_regions_mod.f90 eq_regions_mod.F90 sourcefile~set2pe_mod.f90->sourcefile~eq_regions_mod.f90 sourcefile~sharedmem_mod.f90 sharedmem_mod.F90 sourcefile~tpm_ctl.f90->sourcefile~sharedmem_mod.f90 sourcefile~tpm_fft.f90->sourcefile~parkind_ectrans.f90 sourcefile~tpm_fields.f90->sourcefile~parkind_ectrans.f90 sourcefile~tpm_flt.f90->sourcefile~parkind_ectrans.f90 sourcefile~seefmm_mix.f90 seefmm_mix.F90 sourcefile~tpm_flt.f90->sourcefile~seefmm_mix.f90 sourcefile~tpm_geometry.f90->sourcefile~parkind_ectrans.f90 sourcefile~tpm_hicfft.f90->sourcefile~parkind_ectrans.f90 sourcefile~growing_allocator_mod.f90 growing_allocator_mod.F90 sourcefile~tpm_hicfft.f90->sourcefile~growing_allocator_mod.f90 sourcefile~eq_regions_mod.f90->sourcefile~parkind_ectrans.f90 sourcefile~seefmm_mix.f90->sourcefile~parkind_ectrans.f90 sourcefile~wts500_mod.f90 wts500_mod.F90 sourcefile~seefmm_mix.f90->sourcefile~wts500_mod.f90 sourcefile~wts500_mod.f90->sourcefile~parkind_ectrans.f90

Source Code

! (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, 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('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))
ALLOCATE(IALLMS(ISMAX+1))
ALLOCATE(IKN(0:ISMAX))
IF(ISMAX /= R%NSMAX) THEN
  CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,&
   & KDIM0G=IDIM0G,KSPEC2MX=ISPEC2MX,KUMPP=IUMPP,KALLMS=IALLMS,KPTRMS=IPTRMS)
  ISPEC2_G = (ISMAX+1)*(ISMAX+2)
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(:)
ENDIF
DO J=0,ISMAX
  IKN(J)=2*(ISMAX+1-J)
ENDDO
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,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,KSORT)

DEALLOCATE(IDIM0G)

IF (LHOOK) CALL DR_HOOK('DIST_SPEC',1,ZHOOK_HANDLE)
!endif INTERFACE

!     ------------------------------------------------------------------

END SUBROUTINE DIST_SPEC