spmd_dyn.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

      xdistxy(:) = 0

      lonn = plon / nprxy_x
      workleft = plon - lonn * nprxy_x
      if ( lonn .lt. 3 ) then
         write(6,*)'SPMDINIT_DYN: less than 3 xy-longitudes per subdomain'
         call endrun
      endif

      do procid=1,nprxy_x
         xdistxy(procid) = lonn
      enddo

      if ( workleft .ne. 0 ) then
         procids = (nprxy_x+1) / 2
         procidn = procids + 1
         do while ( workleft .ne. 0 )
            if ( procids .eq. 1 ) procids = nprxy_x
            xdistxy(procids) = xdistxy(procids) + 1
            workleft = workleft - 1  
            if ( workleft .ne. 0 ) then
               xdistxy(procidn) = xdistxy(procidn) + 1
               workleft = workleft - 1
            endif
            procidn = procidn + 1
            procids = procids - 1
         enddo
      endif

! Safety check:

      if ( sum(xdistxy) .ne. plon ) then
         write(6,*)'SPMDINIT_DYN:', xdistxy,' does not add up to ', plon
         call endrun
      endif

      if (workleft/=0) then
         write(6,*)'SPMDINIT_DYN: Workleft(xy-x) not zero.  Value is ',workleft
         call endrun
      end if

! Compute local limits

      beglonxy = 1
      endlonxy = xdistxy(1)
      do procid = 1, myidxy_x
         beglonxy = endlonxy + 1
         endlonxy = beglonxy + xdistxy(procid+1) - 1
      enddo

! Compute global table

      allocate (lonrangexy(2,nprxy_x))
      lonrangexy(1,1) = 1
      lonrangexy(2,1) = xdistxy(1)
      do procid = 2, nprxy_x
         lonrangexy(1,procid) = lonrangexy(2,procid-1) + 1
         lonrangexy(2,procid) = lonrangexy(1,procid) + xdistxy(procid) - 1
      enddo
!
! Compute y secondary decomposition
!
      allocate (ydistxy (nprxy_y))

      ydistxy(:) = 0

      lat = plat / nprxy_y
      workleft = plat - lat * nprxy_y
      if ( lat .lt. 3 ) then
         write(6,*)'SPMDINIT_DYN: less than 3 xy-latitudes per subdomain'
         call endrun
      endif

      do procid=1,nprxy_y
         ydistxy(procid) = lat
      enddo

      if ( workleft .ne. 0 ) then
         procids = (nprxy_y+1) / 2
         procidn = procids + 1
         do while ( workleft .ne. 0 )
            if ( procids .eq. 1 ) procids = nprxy_y
            ydistxy(procids) = ydistxy(procids) + 1
            workleft = workleft - 1  
            if ( workleft .ne. 0 ) then
               ydistxy(procidn) = ydistxy(procidn) + 1
               workleft = workleft - 1
            endif
            procidn = procidn + 1
            procids = procids - 1
         enddo
      endif

! Safety check:

      if ( sum(ydistxy) .ne. plat ) then
         write(6,*)'SPMDINIT_DYN:', ydistxy,' does not add up to ', plat
         call endrun
      endif

      if (workleft/=0) then
         write(6,*)'SPMDINIT_DYN: Workleft(xy-y) not zero.  Value is ',workleft
         call endrun
      end if

! Compute local limits

      beglatxy = 1
      endlatxy = ydistxy(1)
      do procid = 1, myidxy_y
         beglatxy = endlatxy + 1
         endlatxy = beglatxy + ydistxy(procid+1) - 1
      enddo

! Compute global table

      allocate (latrangexy(2,nprxy_y))
      latrangexy(1,1) = 1
      latrangexy(2,1) = ydistxy(1)
      do procid = 2, nprxy_y
         latrangexy(1,procid) = latrangexy(2,procid-1) + 1
         latrangexy(2,procid) = latrangexy(1,procid) + ydistxy(procid) - 1
      enddo
!
! WS: create decompositions for NCAR data structures
!
      xdist(1) = plon
!
! Create PILGRIM decompositions (see decompmodule)
!
      call decompcreate( 1, npr_y, xdist, ydist, strip2d )
      call decompcreate( 1, npr_y, npr_z, xdist, ydist, zdist, strip3dxyz )
      call decompcreate( "xzy", 1, npr_z, npr_y, xdist, zdist, ydist, strip3dxzy )

! In q3 the tracer number and latitude are folded together

      ydistq(:) =  ppcnst * ydist(:)
      call decompcreate( "xzy", 1, npr_z, npr_y, xdist, zdist, ydistq, strip3dq3old )

      ydistq(:) =  plon * ydist(:)
      zdist1(1) =  ppcnst
      call decompcreate( npr_y, npr_z, 1, ydistq, zdist, zdist1, strip3dq3 )

! For y communication within z subdomain (klast version)
      zdist1(1) = endlev-beglev+1
      call decompcreate( 1, npr_y, 1, xdist, ydist, zdist1, strip3yatz )

! For z communication within y subdomain

      ydistk(1) = endlat-beglat+1
      call decompcreate( 1, 1, npr_z, xdist, ydistk, zdist, strip3zaty )
      ydistk(1) = endlat-beglat+3
      call decompcreate( 1, 1, npr_z, xdist, ydistk, zdist, strip3zatyj2 )

! For uv3s_update gathering

      ydistk(1) = 4*(endlat-beglat+1)
      call decompcreate( "xzy", 1, npr_z, 1, xdist, zdist, ydistk, strip3zatyt4 )

! Arrays dimensioned plev+1

      zdist(npr_z) = zdist(npr_z) + 1
      call decompcreate( 1, npr_y, npr_z, xdist, ydist, zdist, strip3dxyzp )
      call decompcreate( "xzy", 1, npr_z, npr_y, xdist, zdist, ydist, strip3dxzyp )

! Arrays dimensioned plev+1, within y subdomain

      ydistk(1) = endlat-beglat+1
      call decompcreate( "xzy", 1, npr_z, 1, xdist, zdist, ydistk, strip3zatypt )
      ydistk(1) = endlat-beglat+2
      call decompcreate( 1, 1, npr_z, xdist, ydistk, zdist, strip3zatypj1 )
      ydistk(1) = endlat-beglat+3
      call decompcreate( 1, 1, npr_z, xdist, ydistk, zdist, strip3zatypj2 )

! For y communication within z subdomain (klast+1 version)
      zdist1(1) = endlev-beglev+2
      call decompcreate( 1, npr_y, 1, xdist, ydist, zdist1, strip3yatzp )

! Secondary xy decomposition
!
      if (twod_decomp .eq. 1) then
        zdistxy(1) = plev
        call decompcreate( nprxy_x, nprxy_y, 1, xdistxy, ydistxy, zdistxy, strip3kxyz )
        call decompcreate( "xzy", nprxy_x, 1, nprxy_y, xdistxy, zdistxy, ydistxy, strip3kxzy )

        zdist1(1)  = ppcnst * zdistxy(1)
        call decompcreate( "xyz", nprxy_x, nprxy_y, 1, xdistxy, ydistxy, zdist1, strip3kq3 )

        zdistxy(1) = zdistxy(1) + 1
        call decompcreate( nprxy_x, nprxy_y, 1, xdistxy, ydistxy, zdistxy, strip3kxyzp )
        call decompcreate( "xzy", nprxy_x, 1, nprxy_y, xdistxy, zdistxy, ydistxy, strip3kxzyp )

! Initialize transposes
!
        call redistributecreate(strip3dxyz, strip3kxyz, inter_ijk)
        call redistributecreate(strip3dxzy, strip3kxzy, inter_ikj)
        call redistributecreate(strip3dxyzp, strip3kxyzp, inter_ijkp)
        call redistributecreate(strip3dxzyp, strip3kxzyp, inter_ikjp)
        call redistributecreate(strip3dq3, strip3kq3, inter_q3)
      endif

!
! Do generic NCAR decomposition
!
      do procid=0,npes-1
         if (iam .eq. 0) then
            write(6,*)'procid ',procid,' assigned ', &
                 cut(2,procid)-cut(1,procid)+1,' latitude values from', &
                 cut(1,procid),' through ',cut(2,procid)
         endif
!
! Determine which processor is responsible for the defined latitudes
!
         do lat=cut(1,procid),cut(2,procid)
            proc(lat) = procid
         end do
      end do
!
! Number of neighbor processors needed for boundary communication.  North
! first.
!
      isum = 0
      do procid=myid_y+1,npr_y-1
         nmostlat = cut(2,procid)
         isum = isum + cut(2,procid) - cut(1,procid) + 1
         if (isum >= numbnd) goto 20
      end do
20    if (myid_y /= npr_y-1 .and. isum < numbnd .and. nmostlat /= plat)then
         write (6,*) 'SPMDINIT_DYN: Something wrong in computation of northern neighbors'
         call endrun
      end if

      isum = 0
      do procid=myid_y-1,0,-1
         smostlat = cut(1,procid)
         isum = isum + cut(2,procid) - cut(1,procid) + 1
         if (isum >= numbnd) goto 30
      end do
30    if (myid_y /= 0 .and. isum < numbnd .and. smostlat /= 1) then
         write(6,*)'Something wrong in computation of southern neighbors'
         call endrun
      end if

!      write(6,*)'-----------------------------------------'
!      write(6,*)'Number of lats passed north & south = ',numbnd
!      write(6,*)'Node  Partition'
!      write(6,*)'-----------------------------------------'
!      do procid=0,npes-1
!         write(6,200) procid,cut(1,procid),cut(2,procid)
!      end do
!      write(6,*)'iam=',iam,'Number of south neighbors needed for bndry exchange = ',neighs
!      write(6,*)'iam=',iam,'Number of north neighbors needed for bndry exchange = ',neighn

      deallocate (ydist)
      deallocate (zdist)

      return
!
! Formats
!
200   format(i3,4x,i3,'-',i3,7x,i3,'-',i3)

!EOC
   end subroutine spmdinit_dyn

!========================================================================

   subroutine decomp_wavenumbers
!----------------------------------------------------------------------- 
! 
! Purpose: partition the spectral work among the given number of processors
! 
! Method: Make the labor division as equal as possible given loop lengths
! 
! Author: CCM Core Group
! 
!-----------------------------------------------------------------------
      implicit none
      
      write(6,*)'decomp_wavenumbers() should never be called in LR dynamics'
      call endrun

   end subroutine decomp_wavenumbers

   subroutine spmdbuf
!----------------------------------------------------------------------- 
! 
! Purpose: placeholder for buffer allocation routine 
! 
! Method: Make the labor division as equal as possible given loop lengths
! 
! Author: CCM Core Group
! 
!-----------------------------------------------------------------------
      implicit none
      
      write(6,*)'spmdbuf() should never be called in LR dynamics'
      call endrun

   end subroutine spmdbuf

   subroutine compute_gsfactors (numperlat, numtot, numperproc, displs)
!----------------------------------------------------------------------- 
! 
! Purpose: Compute arguments for gatherv, scatterv
! 
! Author: CCM Core Group
! 
!-----------------------------------------------------------------------
!
! Input arguments
!
      integer, intent(in) :: numperlat            ! number of elements per latitude
!
! Output arguments
!
      integer, intent(out) :: numtot               ! total number of elements (to send or recv)
      integer, intent(out) :: numperproc(0:npes-1) ! per-PE number of items to receive
      integer, intent(out) :: displs(0:npes-1)     ! per-PE displacements
!
! Local variables
!
      integer :: p                    ! index
   
      numtot = numperlat*numlats
   
      do p=0,npes-1
         numperproc(p) = numperlat*nlat_p(p)
      end do
     
      displs(0) = 0
      do p=1,npes-1
         displs(p) = displs(p-1) + numperproc(p-1)
      end do
     
   end subroutine compute_gsfactors

#endif

end module spmd_dyn