mo_decomposition.f90
MODULE mo_decomposition
!
!+ $Id: mo_decomposition.f90,v 1.29 1999/09/28 10:09:17 m214030 Exp $
!
5: USE mo_exception, ONLY : finish
IMPLICIT NONE
PRIVATE
10: !
! Data type declaration
!
PUBLIC :: pe_decomposed ! data type to hold decomposition for
! a single PE
15: !
! Module varisbles
!
PUBLIC :: global_decomposition ! decomposition table for all PEs
PUBLIC :: local_decomposition ! decomposition info for this PE
20: PUBLIC :: debug_parallel ! Debug flag: -1= no debugging, 0,1=debugging
PUBLIC :: debug_seriell ! .true. to use old scheme to cycle longitudes
! compatible with seriell model version.
! works only for nprocb==1
!
25: ! Module procedures
!
PUBLIC :: decompose ! derive decomposition table
PUBLIC :: print_decomposition ! print decomposition table
30: ! Data type for local information of decomposition per PE
TYPE pe_decomposed
! Information regarding the whole model domain and discretization
35:
INTEGER :: nlon ! number of longitudes
INTEGER :: nlat ! number of latitudes
INTEGER :: nlev ! number of levels
INTEGER :: nm ! max. wavenumber used(triangular truncation)
40: INTEGER ,POINTER :: nnp(:) ! number of points on each m-column
INTEGER ,POINTER :: nmp(:) ! displacement of the first point of
! m-columns with respect to the first point
! of the first m-column
45: ! General information on the decomposition
INTEGER :: d_nprocs ! # of PEs for debugging/non-debugging domain
INTEGER :: spe ! index # of first PE of domain
INTEGER :: epe ! index # of last PE of domain
50: INTEGER :: nprocb !#of PEs for dimension that counts longitudes
INTEGER :: nproca !#of PEs for dimension that counts latitudes
INTEGER ,POINTER :: mapmesh(:,:) ! indirection array mapping from a
! logical 2-d mesh to the processor index
! numbers
55: ! local information
INTEGER :: pe ! PE id
INTEGER :: set_b ! PE id in direction of longitudes
INTEGER :: set_a ! PE id in direction of latitudes
60:
! Grid space decomposition
INTEGER :: nglat ! number of latitudes on PE
INTEGER :: nglon ! number of longitudes on PE
65: INTEGER :: nglpx ! number of longitudes allocated
INTEGER :: glats(2) ! start values of latitudes
INTEGER :: glate(2) ! end values of latitudes
INTEGER :: glons(2) ! start values of longitudes
INTEGER :: glone(2) ! end values of longitudes
70: INTEGER ,POINTER :: glat(:) ! global latitude index
INTEGER ,POINTER :: glon(:) ! offset to global longitude
! Fourier space decomposition
75: LOGICAL :: lfused ! true if this PE used in Fourier space
INTEGER :: nflat ! number of latitudes on PE
INTEGER :: nflev ! number of levels on PE
INTEGER :: nflevp1 ! number of levels+1 on PE
INTEGER :: flats(2) ! start values of latitudes (on row)
80: INTEGER :: flate(2) ! end values of latitudes (on row)
INTEGER :: flevs ! start values of levels (on column)
INTEGER :: fleve ! end values of levels (on column)
! Legendre space decomposition
85:
! Row of PEs with same set_a
INTEGER :: nlm ! number of local wave numbers m handled
INTEGER ,POINTER :: lm(:) ! actual local wave numbers m handled
INTEGER :: lnsp ! number of complex spectral coefficients
90: INTEGER ,POINTER :: nlmp(:) ! displacement of the first point of columns
INTEGER ,POINTER :: nlnp(:) ! number of points on each column
INTEGER :: nlnm0 ! number of coeff. with m=0 on this pe
INTEGER ,POINTER :: intr(:) ! index array used by transpose routine
95: ! Column of PEs with same set_b
INTEGER :: nllev ! number of levels
INTEGER :: nllevp1 ! number of levels+1
INTEGER :: llevs ! start values of levels
INTEGER :: lleve ! end values of levels
100:
! Spectral space decomposition
! local PE
INTEGER :: snsp ! number of spectral coefficients
105: INTEGER :: snsp2 ! 2*number of spectral coefficients
INTEGER :: ssps ! first spectral coefficient
INTEGER :: sspe ! last spectral coefficient
LOGICAL :: lfirstc ! true, if first global coeff (m=0,n=0) on
110: ! this PE (for nudging)
INTEGER :: ifirstc ! location of first global coeff on this PE
INTEGER ,POINTER :: np1(:) ! value of (n+1) for all coeffs of this PE
INTEGER ,POINTER :: mymsp(:) ! value of m for all coeffs of this PE
INTEGER :: nns ! number of different n-values for this PE
115: INTEGER ,POINTER :: nindex(:) ! the nns elements contain the
! values of (n+1)
INTEGER :: nsm ! number of wavenumbers per PE
INTEGER ,POINTER :: sm (:) ! actual local wave numbers handled
120: INTEGER ,POINTER :: snnp(:) ! number of n coeff. per wave number m
INTEGER ,POINTER :: snn0(:) ! first coeff. n for a given m
INTEGER :: nsnm0 ! number of coeffs with m=0 on this pe
END TYPE pe_decomposed
125:
! Module variables
TYPE (pe_decomposed), POINTER, SAVE :: global_decomposition(:)
TYPE (pe_decomposed), SAVE :: local_decomposition
130:
INTEGER :: debug_parallel = -1
! -1 no debugging
! 0 gather from PE0
! 1 gather from PE>0
135: LOGICAL :: debug_seriell = .FALSE.
! .true. to use old scheme to cycle longitudes
! compatible with seriell model version.
! works only for nprocb==1
140: CONTAINS
! Module routines
SUBROUTINE decompose (global_dc, nproca, nprocb, nlat, nlon, nlev, &
145: & nm, nn, nk, norot, debug, lfull_m)
USE mo_doctor, ONLY: nerr
USE mo_mpi, ONLY: p_nprocs, p_set_communicator
150: TYPE (pe_decomposed),INTENT(out) :: global_dc(0:) ! decomposition table
INTEGER ,INTENT(in) :: nproca, nprocb ! no pe's in set A,B
INTEGER ,INTENT(in) :: nlat, nlon, nlev! grid space size
INTEGER ,INTENT(in) :: nk, nm, nn ! truncation
LOGICAL ,OPTIONAL ,INTENT(in) :: norot ! T:no lons rotation
155: INTEGER ,OPTIONAL ,INTENT(in) :: debug ! run full model on PE0
LOGICAL ,OPTIONAL ,INTENT(in) :: lfull_m ! T: full columns
INTEGER :: pe, i
INTEGER :: nprocs
160: LOGICAL :: nor
LOGICAL :: lfullm
IF (nlat/2 < nproca) THEN
CALL finish ('decompose', &
165: & 'Too many PEs selected for nproca - must be <= nlat/2.')
END IF
IF (nm+1 < nproca) THEN
CALL finish ('decompose', &
170: & 'Too many PEs selected for nproca - must be <= nm+1.')
END IF
IF (nk /= nm .OR. nn /= nm) THEN
CALL finish ('decompose', &
175: & 'Only triangular truncations supported in parallel mode.')
END IF
nor = .FALSE.; IF (PRESENT(norot )) nor = norot
nprocs = nproca*nprocb
180: IF (PRESENT(debug)) debug_parallel = debug
lfullm = .FALSE.
IF (PRESENT(lfull_m)) lfullm = lfull_m
pe = 0
185: IF (debug_parallel >= 0) THEN
ALLOCATE (global_dc(pe)%mapmesh(1:1,1:1))
global_dc(pe)% d_nprocs = 1 ! # of PEs for debug domain
global_dc(pe)% spe = 1 ! index number of first PE for debug domain
global_dc(pe)% epe = 1 ! index number of last PE for debug domain
190:
DO i=pe+1,UBOUND(global_dc,1)
ALLOCATE (global_dc(i)%mapmesh(1:nprocb,1:nproca))
END DO
global_dc(pe+1:)% d_nprocs = p_nprocs - 1 ! normal domain
195: global_dc(pe+1:)% spe = 2 ! normal domain
global_dc(pe+1:)% epe = p_nprocs ! normal domain
ELSE
DO i=pe,UBOUND(global_dc,1)
ALLOCATE (global_dc(i)%mapmesh(1:nprocb,1:nproca))
200: END DO
global_dc(pe:)% d_nprocs = p_nprocs
global_dc(pe:)% spe = 1
global_dc(pe:)% epe = p_nprocs
END IF
205:
IF (debug_parallel >= 0) THEN
!
! debug: PE 0 takes whole domain
!
210: CALL set_decomposition (global_dc(pe:pe), pe, 1, 1, .TRUE., lfullm)
! from now on the coordinates of the debug PE in the logical
! mesh must be different from all other PEs' coordinates in order
! to avoid communication in the transposition routines
pe = pe + 1
215: nprocs = nprocs + 1
END IF
IF (nprocs /= SIZE(global_dc)) THEN
WRITE(nerr,*) 'nprocs,size(global_dc):', nprocs, SIZE(global_dc)
220: CALL finish ('decompose', 'wrong size of global_dc.')
END IF
IF (nprocs /= p_nprocs) THEN
CALL finish('decompose', &
225: & 'Inconsistent total number of used PEs.')
END IF
CALL set_decomposition (global_dc(pe:), pe, nproca, nprocb, nor, lfullm)
230: CALL p_set_communicator (nproca, nprocb, global_dc(pe)%mapmesh, &
debug_parallel)
CONTAINS
235: SUBROUTINE set_decomposition (dc, pe, nproca, nprocb, noro, lfullm)
TYPE (pe_decomposed) :: dc(0:) ! decomposition table
INTEGER :: pe ! pe of dc(0)
INTEGER :: nproca, nprocb ! no pe's in columns and rows
240: LOGICAL :: noro ! T: no lons rotation
LOGICAL :: lfullm ! T: full columns
INTEGER :: mepmash(nprocb,nproca)
INTEGER :: i, p
245:
p = pe
DO i = 0, UBOUND(dc,1)
dc(i)%pe = p ! local PE id
250:
CALL mesh_map_init(-1, nprocb, nproca, pe, mepmash)
dc(i)%mapmesh(:,:) = mepmash(:,:)
CALL mesh_index(dc(i)%pe, nprocb, nproca, dc(i)%mapmesh, &
255: dc(i)%set_b, dc(i)%set_a)
CALL decompose_global (dc, nlon, nlat, nlev, nm, nproca, nprocb)
CALL decompose_grid (dc(i), nlon, nlat, nproca, nprocb, noro)
CALL decompose_level (dc(i), nlev, nprocb)
260: CALL decompose_wavenumbers_row (dc(i), nm, nproca)
CALL decompose_specpoints_pe (dc(i), nm, nprocb, lfullm)
p = p+1
265: END DO
END SUBROUTINE set_decomposition
END SUBROUTINE decompose
270:
SUBROUTINE decompose_global (global_dc, nlon, nlat, nlev, nm, nproca,nprocb)
TYPE (pe_decomposed) ,INTENT(inout) :: global_dc(:)
INTEGER ,INTENT(in) :: nlon, nlat, nlev, nm, nproca, nprocb
! local scalars
275: INTEGER :: m, nn, nk, i
! executable statements
global_dc% nlon = nlon
280: global_dc% nlat = nlat
global_dc% nlev = nlev
global_dc% nm = nm
global_dc% nproca = nproca
global_dc% nprocb = nprocb
285: nn = nm; nk = nm
DO i=1,SIZE(global_dc,1)
ALLOCATE (global_dc(i)% nnp(nm+1))
ALLOCATE (global_dc(i)% nmp(nm+2))
globaL_dc(i)%nnp=-999
290: global_dc(i)%nmp=-999
END DO
DO m=0,nm
global_dc(1)% nmp(1) = 0
global_dc(1)% nnp(m+1) = MIN (nk-m,nn) + 1
295: global_dc(1)% nmp(m+2) = global_dc(1)% nmp(m+1) + global_dc(1)% nnp(m+1)
END DO
DO i=2,SIZE(global_dc,1)
global_dc(i)% nnp = global_dc(1)% nnp
global_dc(i)% nmp = global_dc(1)% nmp
300: END DO
END SUBROUTINE decompose_global
SUBROUTINE decompose_grid (pe_dc, nlon, nlat, nproca, nprocb, norot)
305:
TYPE (pe_decomposed), INTENT(inout) :: pe_dc
INTEGER, INTENT(in) :: nlon, nlat, nproca, nprocb
LOGICAL, INTENT(in) :: norot
310: INTEGER :: ngl, i, inp, inprest
INTEGER :: nptrlat(nproca+1), nptrlon(nprocb+1)
INTEGER :: set_a, set_b
315:
! executable statements
set_a = pe_dc%set_a
set_b = pe_dc%set_b
320:
! first distribute latitudes
ngl = nlat/2
325: nptrlat(:) = -999
inp = ngl/nproca
inprest = ngl-inp*nproca
nptrlat(1) = 1
330: DO i = 1, nproca
IF (i <= inprest) THEN
nptrlat(i+1) = nptrlat(i)+inp+1
ELSE
nptrlat(i+1) = nptrlat(i)+inp
335: END IF
END DO
! now distribute longitudes
340: nptrlon(:) = -999
inp = nlon/nprocb
inprest = nlon-inp*nprocb
nptrlon(1) = 1
345: DO i = 1, nprocb
IF (i <= inprest) THEN
nptrlon(i+1) = nptrlon(i)+inp+1
ELSE
nptrlon(i+1) = nptrlon(i)+inp
350: END IF
END DO
! define parts per pe
355: ! latitudes
pe_dc% nglat = 2*(nptrlat(set_a+1)-nptrlat(set_a))
pe_dc% glats(1) = nptrlat(set_a)
360: pe_dc% glate(1) = nptrlat(set_a+1)-1
pe_dc% glats(2) = nlat-nptrlat(set_a+1)+2
pe_dc% glate(2) = nlat-nptrlat(set_a)+1
365: ALLOCATE (pe_dc% glat( pe_dc% nglat))
pe_dc% glat(1:pe_dc% nglat/2) = (/(i,i=pe_dc% glats(1),pe_dc% glate(1))/)
pe_dc% glat(pe_dc% nglat/2+1:) = (/(i,i=pe_dc% glats(2),pe_dc% glate(2))/)
! longitudes
370:
pe_dc% glons(1) = nptrlon(set_b)
pe_dc% glone(1) = nptrlon(set_b+1)-1
pe_dc% nglon = nptrlon(set_b+1)-nptrlon(set_b)
375:
! rotate longitudes in southern area
IF (norot) THEN
pe_dc% glons(2) = pe_dc% glons(1)
380: pe_dc% glone(2) = pe_dc% glone(1)
ELSE
pe_dc% glons(2) = MOD(nptrlon(set_b)-1+nlon/2, nlon)+1
pe_dc% glone(2) = MOD(nptrlon(set_b+1)-2+nlon/2, nlon)+1
END IF
385: ALLOCATE (pe_dc% glon( pe_dc% nglat))
pe_dc% glon(1:pe_dc% nglat/2) = pe_dc% glons(1)-1
pe_dc% glon(pe_dc% nglat/2+1:) = pe_dc% glons(2)-1
! number of longitudes to allocate
390:
IF (norot .AND. nproca*nprocb==1) THEN
pe_dc% nglpx = pe_dc% nglon + 2
ELSE
pe_dc% nglpx = pe_dc% nglon
395: END IF
END SUBROUTINE decompose_grid
SUBROUTINE decompose_level (pe_dc, nlev, nprocb)
400:
! determine number of local levels for fourier and legendre calculations
! this is based on the supplied nflev and nprocb
TYPE (pe_decomposed), INTENT(inout) :: pe_dc
405: INTEGER, INTENT(in) :: nlev, nprocb
INTEGER :: set_b
INTEGER :: inp, inprest, jb
410: INTEGER :: ll(nprocb+1), nptrll(nprocb+1)
! executable statements
set_b = pe_dc%set_b
415:
! latitudes are the same as in grid space
pe_dc% nflat = pe_dc% nglat
pe_dc% flats = pe_dc% glats
420: pe_dc% flate = pe_dc% glate
! distribute levels
inp = (nlev+1)/nprocb
425: inprest = (nlev+1)-inp*nprocb
! make sure highest level is on a PE which has one of the subsets with an extra
! level => improves load-balance
nptrll(nprocb+1)=nlev+1+1
430: DO jb = nprocb,1,-1
IF ((nprocb - jb + 1) <= inprest) THEN
ll(jb) = inp+1
ELSE
ll(jb) = inp
435: END IF
nptrll(jb) = nptrll(jb+1)-ll(jb)
END DO
pe_dc%nflevp1 = ll(set_b)
440: pe_dc%flevs = nptrll(set_b)
pe_dc%fleve = nptrll(set_b+1)-1
pe_dc% lfused = pe_dc%nflevp1 > 0
IF ( pe_dc%fleve > nlev ) THEN
445: pe_dc%nflev = pe_dc%nflevp1 - 1
ELSE
pe_dc%nflev = pe_dc%nflevp1
END IF
450: END SUBROUTINE decompose_level
SUBROUTINE decompose_wavenumbers_row (pe_dc, nm, nproca)
! decompose wavenumbers along latitudinal direction (nproca)
455:
TYPE (pe_decomposed), INTENT(inout) :: pe_dc
INTEGER, INTENT(in) :: nm, nproca
INTEGER :: jm, ik, il, ind
460:
INTEGER :: set_a
INTEGER :: nprocm(0:nm) ! where a certain spectral wave belongs to (set_a)
INTEGER :: nspec(nproca)! complex spectral coefficients per row (set_a)
465: INTEGER :: numpp(nproca)! spectral waves per processor row (set_a)
INTEGER :: myms(nm+1) ! actual wave numbers handled
! executable statements
470: set_a = pe_dc% set_a
! levels same as in Fourier space
pe_dc%nllev = pe_dc%nflev
475: pe_dc%nllevp1 = pe_dc%nflevp1
pe_dc%llevs = pe_dc%flevs
pe_dc%lleve = pe_dc%fleve
! distribute spectral waves
480:
nspec(:) = 0
numpp(:) = 0
myms(:) = -1
485: il = 1
ind = 1
ik = 0
DO jm = 0, nm
ik = ik + ind
490: IF (ik > nproca) THEN
ik = nproca
ind = -1
ELSE IF (ik < 1) THEN
ik = 1
495: ind = 1
END IF
nprocm(jm) = ik
nspec(ik) = nspec(ik)+nm-jm+1
numpp(ik) = numpp(ik)+1
500: IF (ik == set_a) THEN
myms(il) = jm
il = il+1
END IF
END DO
505:
ALLOCATE(pe_dc% lm (numpp(set_a) ))
ALLOCATE(pe_dc% nlmp (numpp(set_a)+1))
ALLOCATE(pe_dc% nlnp (numpp(set_a) ))
ALLOCATE(pe_dc% intr (numpp(set_a)*2))
510:
pe_dc% nlm = numpp(set_a)
pe_dc% lnsp = nspec(set_a)
pe_dc% lm = myms (1:il-1)
pe_dc% nlnp = nm - pe_dc% lm + 1
515: pe_dc%nlnm0 = 0; IF (myms (1)== 0) pe_dc% nlnm0 = pe_dc% nlnp(1)
pe_dc% nlmp(1) = 0
DO jm = 1, pe_dc% nlm
pe_dc% nlmp( jm+1) = pe_dc% nlmp(jm) + pe_dc% nlnp(jm)
pe_dc% intr(2*jm-1) = 2 * pe_dc% lm(jm) + 1
520: pe_dc% intr(2*jm ) = 2 * pe_dc% lm(jm) + 2
END DO
END SUBROUTINE decompose_wavenumbers_row
525: SUBROUTINE decompose_specpoints_pe (pe_dc, nm, nprocb, lfullm)
! Decompose wavenumbers additionally along longitudinal direction (nprocb),
! thus decompose wavenumbers among individual PEs.
! Each PE receives full or partial m-columns, depending on strategy
530: ! chosen. The case with partial m-columns will generally be better load-
! balanced.
USE mo_exception
535: TYPE (pe_decomposed), INTENT(inout) :: pe_dc
INTEGER, INTENT(in) :: nm, nprocb
INTEGER :: nspec, set_b, nump, myml(pe_dc%nlm)
540: INTEGER :: insef, irestf, jb, jmloc, icolset, iave, im, inm, iii, jn, i
INTEGER :: ispec, il, jm, imp, inp, is, ic, inns, nsm, ifirstc
INTEGER :: nptrsv(nprocb+1) ! first spectral wave column (PE column)
INTEGER :: nptrsvf(nprocb+1) ! full spectral wave m-columns (PE column)
545: INTEGER :: nptrmf(nprocb+1) ! distribution of m-columns among PE column
! (used for semi-impl. calculations in
! full m-columns case)
INTEGER :: nspstaf(0:nm) ! m-column starts here (used for
! semi-impl. full m-columns case)
550:
INTEGER :: inumsvf(nprocb+1)
INTEGER :: nns ! number of different n-values for this PE
INTEGER :: nindex(pe_dc%nm+1)! the first nns elements contain the values
555: ! of (n+1);
! for non triangular truncation: pe_dc%nkp1
LOGICAL :: lnp1(pe_dc%nm+1) ! if false: this value of (n+1) has not
! occurred yet
560: INTEGER :: np1(pe_dc%lnsp) ! np1 holds the values of (n+1) of all
! coeffs on this PE
INTEGER :: mymsp(pe_dc%lnsp) ! mymsp holds the values of m of all
! coeffs on this PE
565: INTEGER :: myms(pe_dc%nlm) ! myms holds the values of the wavenumbers
! on this PE
INTEGER :: myns(pe_dc%nlm) ! myns holds the number of coeffs of
! m-columns (full or partial) on this PE
INTEGER :: snn0(pe_dc%nlm) ! snn0 holds the offset of n wavenumbers
570: ! for each column (0 for full)
LOGICAL :: lfullm, ljm, lfirstc
! executable statements
575:
! short names for processor row variables
nspec = pe_dc%lnsp ! number of spectral coefficients in processor row
set_b = pe_dc%set_b
580: nump = pe_dc%nlm ! number of wavenumbers in processor row
myml = pe_dc%lm ! wave numbers handled in processor row
! Partitioning of spectral coefficients in semi-implicit calculations.
585: ! Be careful : nspec varies between processor rows, so nptrsv()
! differs on different processor rows.
insef = nspec/nprocb
irestf = nspec-insef*nprocb
590: nptrsv(1) = 1
DO jb = 2, nprocb+1
IF(jb-1 <= irestf) THEN
nptrsv(jb) = nptrsv(jb-1)+insef+1
ELSE
595: nptrsv(jb) = nptrsv(jb-1)+insef
END IF
END DO
! partitioning of spectral coefficients in semi-implicit calculations
600: ! for the case where complete m-columns are required.
! original idea
nptrmf(:) = 1
605: inumsvf(:) = 0
icolset = MIN(nprocb,nump)
nptrmf(1) = 1
nptrmf(icolset+1:nprocb+1) = nump+1
ispec = nspec
610: iave = (ispec-1)/icolset+1
DO jmloc = nump, 1, -1
im = myml(jmloc)
inm = nm-im+1
IF (inumsvf(icolset) < iave) THEN
615: inumsvf(icolset) = inumsvf(icolset)+inm
ELSE
nptrmf(icolset) = jmloc+1
ispec = ispec-inumsvf(icolset)
icolset = icolset-1
620: IF (icolset == 0) THEN
CALL finish ('decompose_wavenumbers_pe', &
& 'error in decomposition, icolset = 0!')
END IF
iave = (ispec-1)/icolset+1
625: inumsvf(icolset) = inumsvf(icolset)+inm
END IF
END DO
nptrsvf(1) = 1
DO jb = 2, nprocb+1
630: nptrsvf(jb) = nptrsvf(jb-1)+inumsvf(jb-1)
END DO
nspstaf(:) = -999
iii = 1
635: ! DO jmloc = nptrmf(set_b), nptrmf(set_b+1)-1
! nspstaf(myml(jmloc)) = iii
! iii = iii+nm-myms(jmloc)+1
! END DO
640: IF (lfullm) THEN
pe_dc%ssps = nptrsvf(set_b)
pe_dc%sspe = nptrsvf(set_b+1)-1
pe_dc%snsp = nptrsvf(set_b+1)-nptrsvf(set_b)
pe_dc%snsp2= 2*pe_dc%snsp
645: ELSE
pe_dc%ssps = nptrsv(set_b)
pe_dc%sspe = nptrsv(set_b+1)-1
pe_dc%snsp = nptrsv(set_b+1)-nptrsv(set_b)
pe_dc%snsp2= 2*pe_dc%snsp
650: END IF
! il counts spectral coeffs per PE
! nsm counts number of wavenumbers (full or partial) per PE
655:
il = 0
nsm = 0
ljm = .FALSE.
lnp1(:) = .FALSE.
660: nindex(:) = -999
inns = 0
myms(:) = -999
myns(:) = 0
ifirstc = -999
665: lfirstc = .FALSE.
! loop over all coeffs of a processor row and check whether they belong to
! this PE
DO jm = 1,nump
670: imp = pe_dc%nlmp(jm)
inp = pe_dc%nlnp(jm)
DO jn = 1,inp
is = imp + jn
ic = myml(jm) +jn
675:
IF ((is >= pe_dc%ssps) .AND. (is <= pe_dc%sspe)) THEN
IF (.NOT.ljm) snn0 (nsm+1) = jn-1
ljm = .TRUE.
il = il + 1
680:
np1(il) = ic
mymsp(il) = myml(jm)
myns(nsm+1) = myns(nsm+1) + 1
685:
IF (.NOT. lnp1(ic)) THEN
inns = inns + 1
nindex(inns) = ic
lnp1(ic) = .TRUE.
690: END IF
! first global coeff. on this PE? (for nudging)
IF ((mymsp(il) == 0) .AND. (np1(il) == 1)) THEN
lfirstc = .TRUE.
695: ifirstc = il
END IF
END IF
END DO
700: IF (ljm) THEN
nsm = nsm + 1
myms(nsm) = myml(jm)
END IF
ljm = .FALSE.
705: END DO
nns = inns
IF (il /= pe_dc%snsp) THEN
710: CALL finish('decompose', &
& 'Error in computing number of spectral coeffs')
END IF
ALLOCATE (pe_dc%np1(il))
715: ALLOCATE (pe_dc%mymsp(il))
pe_dc%np1 = np1(1:il)
pe_dc%mymsp = mymsp(1:il)
pe_dc%nns = nns
720: ALLOCATE (pe_dc%nindex(pe_dc%nns))
pe_dc%nindex(:) = nindex(1:nns)
pe_dc%lfirstc = lfirstc
pe_dc%ifirstc = ifirstc
725:
pe_dc%nsm = nsm
ALLOCATE (pe_dc%sm (pe_dc%nsm))
ALLOCATE (pe_dc%snnp (pe_dc%nsm))
pe_dc%sm = myms(1:nsm)
730: pe_dc%snnp = myns(1:nsm)
ALLOCATE (pe_dc%snn0 (pe_dc%nsm))
pe_dc%snn0 = snn0 (1:nsm)
735: pe_dc%nsnm0 = 0
DO i=1,nsm
IF (pe_dc%sm(i) == 0) THEN
pe_dc%nsnm0 = pe_dc%snnp(i)
EXIT
740: END IF
END DO
END SUBROUTINE decompose_specpoints_pe
745: SUBROUTINE print_decomposition (dc)
USE mo_doctor, ONLY: nout
USE mo_exception, ONLY: message
750: TYPE (pe_decomposed), INTENT(in) :: dc
WRITE (nout,'(78("_"))')
IF (.NOT. ASSOCIATED(dc%lm)) THEN
CALL message ('print_decomposition', &
755: & 'decomposition not done, cannot print information ...')
END IF
WRITE (nout,'(a,i5)') ' PE : ', dc%pe
WRITE (nout,'(a,i5)') ' Processor row (Set A) : ', dc%set_a
760: WRITE (nout,'(a,i5)') ' Processor column (Set B) : ', dc%set_b
WRITE (nout,*)
WRITE (nout,'(a)') ' mapmesh : '
765: WRITE (nout,'(12i5)') dc%mapmesh
WRITE (nout,*)
WRITE (nout,'(a,i5)') ' spe : ', dc%spe
770: WRITE (nout,'(a,i5)') ' epe : ', dc%epe
WRITE (nout,'(a,i5)') ' d_nprocs : ', dc%d_nprocs
WRITE (nout,*)
775: WRITE (nout,'(a,i5)') ' nlon : ', dc%nlon
WRITE (nout,'(a,i5)') ' nlat : ', dc%nlat
WRITE (nout,'(a,i5)') ' nlev : ', dc%nlev
WRITE (nout,'(a,i5)') ' nm : ', dc%nm
WRITE (nout,'(a,12i5/(9x,12i5))') ' nmp : ',dc%nmp
780: WRITE (nout,'(a,12i5/(9x,12i5))') ' nnp : ',dc%nnp
WRITE (nout,'(a,i5)') ' nproca: ', dc%nproca
WRITE (nout,'(a,i5)') ' nprocb: ', dc%nprocb
WRITE (nout,*)
785:
WRITE (nout,'(i5,a)') dc%nglat, ' latitudes in grid space'
WRITE (nout,'(i5,a)') dc%nglon, ' longitudes in grid space'
WRITE (nout,'(i5,a)') dc%nglpx, ' longitudes allocated'
WRITE (nout,'(i5,a)') dc%nglat*dc%nglon, ' grid points (total)'
790: WRITE (nout,'(4(a,i5))') ' glatse: ', dc%glats(1), ' -', dc%glate(1), &
', ', dc%glats(2), ' -', dc%glate(2)
WRITE (nout,'(4(a,i5))') ' glonse: ', dc%glons(1), ' -', dc%glone(1), &
', ', dc%glons(2), ' -', dc%glone(2)
WRITE (nout,'(a,12i5/(9x,12i5))') ' glat : ', dc% glat
795: WRITE (nout,'(a,12i5/(9x,12i5))') ' glon : ', dc% glon
WRITE (nout,*)
WRITE (nout,'(l4,a)') dc%lfused, ' processor used in Fourier space'
WRITE (nout,'(i5,a)') dc%nflat, ' latitudes in Fourier space'
800: WRITE (nout,'(i5,a)') dc%nflevp1, ' levels+1 in Fourier space'
WRITE (nout,'(i5,a)') dc%nflev, ' levels in Fourier space'
WRITE (nout,'(4(a,i5))') ' flat : ', dc%flats(1), ' -', dc%flate(1), &
', ', dc%flats(2), ' -', dc%flate(2)
WRITE (nout,'(2(a,i5))') ' flev : ', dc%flevs, ' -', dc%fleve
805:
WRITE (nout,*)
WRITE (nout,'(i5,a)') dc%nlm, ' wave numbers in Legendre space'
WRITE (nout,'(a,12i5/(9x,12i5))') ' lm : ', dc%lm(:dc%nlm)
810: WRITE (nout,'(a,12i5/(9x,12i5))') ' nlnp : ', dc%nlnp(:dc%nlm)
WRITE (nout,'(a,12i5/(9x,12i5))') ' nlmp : ', dc%nlmp(:dc%nlm+1)
WRITE (nout,'(i5,a)') dc%nlnm0, ' coefficients for m=0'
WRITE (nout,'(i5,a)') dc%lnsp, ' spectral coefficients'
WRITE (nout,'(i5,a)') dc%nllevp1, ' levels+1 in Legendre space'
815: WRITE (nout,'(i5,a)') dc%nllev, ' levels in Legendre space'
WRITE (nout,'(2(a,i5))') ' llev : ', dc%llevs, ' -', dc%lleve
WRITE (nout,*)
820: WRITE (nout,'(i5,a)') dc%snsp, ' coefficients'
WRITE (nout,'(i5,a)') dc%snsp2, ' coefficients times 2'
WRITE (nout,'(i5,a)') dc%ssps, ' first spectral coefficient'
WRITE (nout,'(i5,a)') dc%sspe, ' last spectral coefficient'
825: WRITE (nout,'(l4,a)') dc%lfirstc, ' first global coefficient on this PE'
WRITE (nout,'(i5,a)') dc%ifirstc, ' local index of first global coefficient'
WRITE (nout,'(a,12i5/(9x,12i5))') ' np1 : ', dc%np1
WRITE (nout,'(a,12i5/(9x,12i5))') ' mymsp : ', dc%mymsp
830: WRITE (nout,'(i5,a)') dc%nns , ' number of different n-values'
WRITE (nout,'(a,12i5/(9x,12i5))') ' nindex: ', dc%nindex
WRITE (nout,'(i5,a)') dc%nsm , ' number of m wave numbers.'
WRITE (nout,'(a,12i5/(9x,12i5))') ' sm : ', dc%sm
835: ! WRITE (nout,'(a,12i5/(9x,12i5))') ' snmp : ', dc%snmp
WRITE (nout,'(a,12i5/(9x,12i5))') ' snnp : ', dc%snnp
WRITE (nout,'(a,12i5/(9x,12i5))') ' snn0 : ', dc%snn0
WRITE (nout,'(i5,a)') dc%nsnm0 , ' coefficients for m=0'
840:
END SUBROUTINE print_decomposition
SUBROUTINE mesh_map_init(option, isize, jsize, p, meshmap)
845: ! all isize*jsize PEs are mapped to a 2-D logical mesh
! starting with PE with id p
INTEGER :: option, isize, jsize, p
INTEGER :: meshmap(1:isize,1:jsize)
850: INTEGER :: i, j
IF (option == 1) THEN
! row major ordering
DO j = 1, jsize
855: DO i = 1, isize
meshmap(i,j) = (i-1) + (j-1)*isize + p
END DO
END DO
ELSE IF (option == -1) THEN
860: !column major ordering
DO j = 1, jsize
DO i = 1, isize
meshmap(i,j) = (j-1) + (i-1)*jsize + p
END DO
865: END DO
END IF
END SUBROUTINE mesh_map_init
870: SUBROUTINE mesh_index(p, isize, jsize, meshmap, idex, jdex)
! returns coordinates (idex,jdex) of PE with id p in logical mesh
INTEGER :: p, isize, jsize, idex, jdex
875: INTEGER :: meshmap(1:isize,1:jsize)
INTEGER :: i, j
LOGICAL :: lexit
idex = -1
880: jdex = -1
lexit = .FALSE.
DO j = 1, jsize
DO i = 1, isize
885: IF (meshmap(i,j) == p) THEN
! coordinates start at 1
idex = i
jdex = j
lexit = .TRUE.
890: EXIT
END IF
END DO
IF (lexit) EXIT
END DO
895: ! check for successful completion of search
IF ((idex == -1) .OR. (jdex == -1)) THEN
CALL finish('mesh_index', &
& 'Unable to find processor in meshmap array')
END IF
900:
END SUBROUTINE mesh_index
END MODULE mo_decomposition
Info Section
uses: mo_doctor, mo_exception, mo_mpi
calls: decompose_global, decompose_grid, decompose_level, decompose_specpoints_pe, decompose_wavenumbers_row
finish, mesh_index, mesh_map_init, message, p_set_communicator
set_decomposition
back to top
ECHAM 4 vf90 (C) 1998 Max-Planck-Institut für Meteorologie, Hamburg
Wed Nov 24 01:25:21 CST 1999
HTML derived from FORTRAN source by f2html.pl v0.3 (C) 1997,98 Beroud Jean-Marc.