sump_trans_mod.F90

Go to the documentation of this file.

MODULE sump_trans_mod
CONTAINS
SUBROUTINE sump_trans

! Set up distributed environment for the transform package (part 2)

USE parkind1  ,ONLY : jpim     ,jprb

USE tpm_gen
USE tpm_dim
USE tpm_geometry
USE tpm_distr

USE suwavedi_mod
USE pe2set_mod
USE sumplatf_mod
USE sumplat_mod
USE sustaonl_mod
USE mysendset_mod
USE myrecvset_mod
USE eq_regions_mod

IMPLICIT NONE

INTEGER(KIND=JPIM) :: JM,JMLOC
INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM
INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1
INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF
INTEGER(KIND=JPIM),ALLOCATABLE :: IGPTOTL(:,:)

LOGICAL    :: LLP1,LLP2

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


llp1 = nprintlev>0
llp2 = nprintlev>1
IF(llp1) WRITE(nout,*) '=== ENTER ROUTINE SUMP_TRANS ==='

ALLOCATE(d%NULTPP(nprtrns))
IF(llp2)WRITE(nout,9) 'D%NULTPP   ',SIZE(d%NULTPP   ),shape(d%NULTPP   )
ALLOCATE(d%NPTRLS(nprtrns))
IF(llp2)WRITE(nout,9) 'D%NPTRLS   ',SIZE(d%NPTRLS   ),shape(d%NPTRLS   )
ALLOCATE(d%NPROCL(r%NDGL))
IF(llp2)WRITE(nout,9) 'D%NPROCL   ',SIZE(d%NPROCL   ),shape(d%NPROCL   )

CALL sumplatf(r%NDGL,nprtrns,mysetw,d%NULTPP,d%NPROCL,d%NPTRLS)
d%NDGL_FS = d%NULTPP(mysetw)

! Help arrays for spectral to fourier space transposition
ALLOCATE(d%NLTSGTB (nprtrns+1))
IF(llp2)WRITE(nout,9) 'D%NLTSGTB ',SIZE(d%NLTSGTB),shape(d%NLTSGTB)
ALLOCATE(d%NLTSFTB (nprtrns+1))
IF(llp2)WRITE(nout,9) 'D%NLTSFTB ',SIZE(d%NLTSFTB),shape(d%NLTSFTB)
ALLOCATE(d%NSTAGT0B(nprtrns+1))
IF(llp2)WRITE(nout,9) 'D%NSTAGT0B ',SIZE(d%NSTAGT0B),shape(d%NSTAGT0B)
ALLOCATE(d%NSTAGT1B(nprtrns+1))
IF(llp2)WRITE(nout,9) 'D%NSTAGT1B ',SIZE(d%NSTAGT1B),shape(d%NSTAGT1B)
ALLOCATE(d%MSTABF  (nprtrns+1))
IF(llp2)WRITE(nout,9) 'D%MSTABF ',SIZE(d%MSTABF),shape(d%MSTABF)

d%NLTSGTB(:) = 0
DO jgl=1,d%NDGL_FS
  igl = d%NPTRLS(mysetw)+jgl-1
  DO jm=0,g%NMEN(igl)
    d%NLTSGTB(d%NPROCM(jm)) = d%NLTSGTB(d%NPROCM(jm))+1
  ENDDO
ENDDO
DO ja=1,nprtrw
  iplat = 0
  DO jgl=1,d%NULTPP(ja)
    igl = d%NPTRLS(ja)+jgl-1
    DO jm=1,d%NUMP
      IF(igl > r%NDGNH-g%NDGLU(d%MYMS(jm)) .AND. igl <= r%NDGNH+g%NDGLU(d%MYMS(jm))) THEN
        iplat = iplat + 1
      ENDIF
    ENDDO
  ENDDO
  d%NLTSFTB(ja) = iplat
ENDDO

DO ja=1,nprtrw-1
  isendset = mysendset(nprtrw,mysetw,ja)
  irecvset = myrecvset(nprtrw,mysetw,ja)
  d%MSTABF(irecvset) = isendset
ENDDO
d%MSTABF(mysetw) = mysetw

ALLOCATE(d%NPNTGTB0(0:r%NSMAX,d%NDGL_FS))
IF(llp2)WRITE(nout,9) 'D%NPNTGTB0 ',SIZE(d%NPNTGTB0 ),shape(d%NPNTGTB0 )
ALLOCATE(d%NPNTGTB1(d%NUMP,r%NDGL))
IF(llp2)WRITE(nout,9) 'D%NPNTGTB1 ',SIZE(d%NPNTGTB1 ),shape(d%NPNTGTB1 )

DO ja=1,nprtrw
  ipos = 0
  DO jgl=1,d%NULTPP(mysetw)
    igl = d%NPTRLS(mysetw) + jgl - 1
    DO jml=d%NPTRMS(ja),d%NPTRMS(ja)+d%NUMPP(ja)-1
      im = d%NALLMS(jml)
      IF (im  <=  g%NMEN(igl)) THEN
        d%NPNTGTB0(im,jgl) = ipos
        ipos = ipos+1
      ELSE
        d%NPNTGTB0(im,jgl) = -99
      ENDIF
    ENDDO
  ENDDO
ENDDO

DO ja=1,nprtrw
  ipos = 0
  DO jgl=1,d%NULTPP(ja)
    igl = d%NPTRLS(ja) + jgl - 1
    DO jm=1,d%NUMP
      im = d%MYMS(jm)
      IF (im  <=  g%NMEN(igl)) THEN
        d%NPNTGTB1(jm,igl) = ipos
        ipos = ipos+1
      ELSE
        d%NPNTGTB1(jm,igl) = -99
      ENDIF
    ENDDO
  ENDDO
ENDDO

iaux0 = 0
iaux1 = 0
DO ja=1,nprtrns-1
  i1 = mysendset(nprtrns,mysetw,ja)
  i2 = myrecvset(nprtrns,mysetw,ja)
  DO ja1=1,nprtrns-1
    IF(mysendset(nprtrns,mysetw,ja1) == i2) i3 =myrecvset(nprtrns,mysetw,ja1)
  ENDDO
  iaux0 = max(d%NLTSFTB(i1),d%NLTSGTB(i2),iaux0)
  iaux1 = max(d%NLTSGTB(i2),d%NLTSFTB(i3),iaux1)
ENDDO
iaux0 = max(d%NLTSGTB(mysetw),iaux0)
iaux1 = max(d%NLTSGTB(mysetw),iaux1)
DO ja=1,nprtrns+1
  d%NSTAGT0B(ja) = (ja-1)*iaux0
  d%NSTAGT1B(ja) = (ja-1)*iaux1
ENDDO
d%NLENGT0B = iaux0*nprtrns
d%NLENGT1B = iaux1*nprtrns

! GRIDPOINT SPACE

ALLOCATE(d%NFRSTLAT(n_regions_ns))
IF(llp2)WRITE(nout,9) 'D%NFRSTLAT ',SIZE(d%NFRSTLAT ),shape(d%NFRSTLAT )
ALLOCATE(d%NLSTLAT(n_regions_ns))
IF(llp2)WRITE(nout,9) 'D%NLSTLAT  ',SIZE(d%NLSTLAT  ),shape(d%NLSTLAT  )
ALLOCATE(d%NPTRLAT(r%NDGL))
IF(llp2)WRITE(nout,9) 'D%NPTRLAT  ',SIZE(d%NPTRLAT  ),shape(d%NPTRLAT  )
ALLOCATE(d%NPTRFRSTLAT(n_regions_ns))
IF(llp2)WRITE(nout,9) 'D%NPTRFRSTLAT',SIZE(d%NPTRFRSTLAT),shape(d%NPTRFRSTLAT)
ALLOCATE(d%NPTRLSTLAT(n_regions_ns))
IF(llp2)WRITE(nout,9)'D%NPTRLSTLAT',SIZE(d%NPTRLSTLAT),shape(d%NPTRLSTLAT)
ALLOCATE(d%LSPLITLAT(r%NDGL))
IF(llp2)WRITE(nout,9) 'D%LSPLITLAT',SIZE(d%LSPLITLAT),shape(d%LSPLITLAT)


CALL sumplat(r%NDGL,nproc,n_regions_ns,my_region_ns,d%LSPLIT,leq_regions,&
             &d%NFRSTLAT,d%NLSTLAT,d%NFRSTLOFF,d%NPTRLAT,&
             &d%NPTRFRSTLAT,d%NPTRLSTLAT,d%NPTRFLOFF,&
             &imediap,irestm,d%LSPLITLAT)

d%NDGL_GP = d%NLSTLAT(my_region_ns)-d%NFRSTLOFF

IF (llp1) THEN
  WRITE(nout,fmt='(/'' OUTPUT FROM ROUTINE SUMPLAT: ''/)')
  WRITE(nout,fmt='('' D%NULTPP '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NULTPP(1:nprtrns)
  WRITE(nout,fmt='('' D%NPROCL '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NPROCL(1:r%NDGL)
  WRITE(nout,fmt='('' D%NFRSTLAT '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NFRSTLAT(1:n_regions_ns)
  WRITE(nout,fmt='('' D%NLSTLAT '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NLSTLAT(1:n_regions_ns)
  WRITE(nout,fmt='('' D%NFRSTLOFF  D%NPTRFLOFF '')')
  WRITE(nout,fmt='(2(1X,I6))') d%NFRSTLOFF, d%NPTRFLOFF
  WRITE(nout,fmt='('' D%NPTRLAT '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NPTRLAT(1:r%NDGL)
  WRITE(nout,fmt='('' D%LSPLITLAT '')')
  WRITE(nout,fmt='(50(1X,L1))') d%LSPLITLAT(1:r%NDGL)
  WRITE(nout,fmt='('' D%NPTRFRSTLAT '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NPTRFRSTLAT(1:n_regions_ns)
  WRITE(nout,fmt='('' D%NPTRLSTLAT '')')
  WRITE(nout,fmt='(20(1X,I4))') d%NPTRLSTLAT(1:n_regions_ns)
  WRITE(nout,fmt='(/)')
ENDIF
ALLOCATE(d%NSTA(r%NDGL+n_regions_ns-1,n_regions_ew))
IF(llp2)WRITE(nout,9) 'D%NSTA     ',SIZE(d%NSTA     ),shape(d%NSTA     )
ALLOCATE(d%NONL(r%NDGL+n_regions_ns-1,n_regions_ew))
IF(llp2)WRITE(nout,9) 'D%NONL     ',SIZE(d%NONL     ),shape(d%NONL     )

CALL sustaonl(imediap,irestm)

!  IGPTOTL is the number of grid points in each individual processor
ALLOCATE(igptotl(n_regions_ns,n_regions_ew))
igptotl(:,:)=0

DO ja=1,n_regions_ns
  DO jb=1,n_regions(ja)
    igptot = 0
    DO jgl=d%NPTRFRSTLAT(ja),d%NPTRLSTLAT(ja)
      igptot = igptot+d%NONL(jgl,jb)
    ENDDO
    igptotl(ja,jb) = igptot
  ENDDO
ENDDO
d%NGPTOT = igptotl(my_region_ns,my_region_ew)
d%NGPTOTMX = maxval(igptotl)
d%NGPTOTG = sum(igptotl)
ALLOCATE(d%NGPTOTL(n_regions_ns,n_regions_ew))
IF(llp2)WRITE(nout,9) 'D%NGPTOTL     ',SIZE(d%NGPTOTL ),shape(d%NGPTOTL  )
d%NGPTOTL(:,:) = igptotl(:,:)

ALLOCATE(d%NSTAGTF(d%NDGL_FS))
IF(llp2)WRITE(nout,9) 'D%NSTAGTF     ',SIZE(d%NSTAGTF ),shape(d%NSTAGTF  )
ioff = 0
DO jgl=1,d%NDGL_FS
  d%NSTAGTF(jgl) = ioff
  igl = d%NPTRLS(mysetw) + jgl - 1
  ioff = ioff + g%NLOEN(igl)+3
ENDDO
d%NLENGTF = ioff

DEALLOCATE(igptotl)

!     ------------------------------------------------------------------
9 FORMAT(1x,'ARRAY ',a10,' ALLOCATED ',8i8)

END SUBROUTINE sump_trans
END MODULE sump_trans_mod