phys_grid.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

            glat = chunks(cid)%lat(i) 
            block_cnt = get_block_coord_cnt_d(glon,glat)
            call get_block_coord_d(glon,glat,block_cnt,blockids,bcids)
            do jb=1,block_cnt
               owner_d = get_block_owner_d(blockids(jb)) 
               if (owner_d .ne. chunks(cid)%owner) then
                  local_dp_map = .false.   
               endif
            enddo
         enddo
      enddo
!
! Allocate and initialize data structures for gather/scatter
!  
      allocate ( pgcols(1:ngcols) )
      allocate ( gs_col_num(0:npes-1) )
      allocate ( gs_col_offset(0:npes) )

      pchunkid = 0
      endpchunk = 0
      curgcol = 0
      do p=0,npes-1
         gs_col_offset(p) = curgcol + 1
         begpchunk = endpchunk + 1
         plchunks = 0
         gs_col_num(p) = 0
         do cid=1,nchunks
            if (chunks(cid)%owner == p) then
               pchunkid = pchunkid + 1

               plchunks = plchunks + 1
               chunks(cid)%lchunk = pchunkid + lastblock

               do i=1,chunks(cid)%ncols
                  curgcol = curgcol + 1
                  pgcols(curgcol)%chunk = cid
                  pgcols(curgcol)%ccol = i
                  gs_col_num(p) = gs_col_num(p) + 1
               enddo

            endif
         enddo
         endpchunk = begpchunk + plchunks - 1
         if (iam == p) then
!
! Local chunk index range chosen so that it does not overlap 
! {begblock,...,endblock}
! 
            nlchunks = plchunks
            begchunk = begpchunk + lastblock
            endchunk = endpchunk + lastblock
         endif
      enddo
      gs_col_offset(npes) = curgcol + 1
      nlcols = gs_col_num(iam)
!
      allocate ( lchunks(begchunk:endchunk) )
      do cid=1,nchunks
         if (chunks(cid)%owner == iam) then
            lchunks(chunks(cid)%lchunk) = cid
         endif
      enddo
!
   endif
!
   if (.not. local_dp_map) then
!
! allocate and initialize data structures for transposes
!  
      allocate ( btofc_blk_num(0:npes-1) )
      allocate ( btofc_blk_offset(firstblock:lastblock) )
      do jb = firstblock,lastblock
         nullify( btofc_blk_offset(jb)%pter )
      enddo
!
      glbcnt = 0
      curcnt = 0
      curp = 0
      do curgcol=1,ngcols
         cid = pgcols(curgcol)%chunk
         i   = pgcols(curgcol)%ccol
         owner_p   = chunks(cid)%owner
         do while (curp < owner_p)
            btofc_blk_num(curp) = curcnt
            curcnt = 0
            curp = curp + 1
         enddo
         glon = chunks(cid)%lon(i)
         glat = chunks(cid)%lat(i)
         block_cnt = get_block_coord_cnt_d(glon,glat)
         call get_block_coord_d(glon,glat,block_cnt,blockids,bcids)
         do jb = 1,block_cnt
            owner_d = get_block_owner_d(blockids(jb))
            if (iam == owner_d) then
               if (.not. associated(btofc_blk_offset(blockids(jb))%pter)) then
                  blksiz = get_block_col_cnt_d(blockids(jb))
                  numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb))
                  btofc_blk_offset(blockids(jb))%ncols = blksiz
                  btofc_blk_offset(blockids(jb))%nlvls = numlvl
                  allocate ( btofc_blk_offset(blockids(jb))%pter(blksiz,numlvl) )
               endif
               do k=1,btofc_blk_offset(blockids(jb))%nlvls
                  btofc_blk_offset(blockids(jb))%pter(bcids(jb),k) = glbcnt
                  curcnt = curcnt + 1
                  glbcnt = glbcnt + 1
               enddo
            endif
         enddo
      enddo
      btofc_blk_num(curp) = curcnt
      block_buf_nrecs = glbcnt
!  
      allocate ( btofc_chk_num(0:npes-1) )
      allocate ( btofc_chk_offset(begchunk:endchunk) )
      do lchnk=begchunk,endchunk
         ncol = chunks(lchunks(lchnk))%ncols
         btofc_chk_offset(lchnk)%ncols = ncol
         btofc_chk_offset(lchnk)%nlvls = pver+1
         allocate ( btofc_chk_offset(lchnk)%pter(ncol,pver+1) )
      enddo
!
      curcnt = 0
      glbcnt = 0
      do p=0,npes-1
         do curgcol=gs_col_offset(iam),gs_col_offset(iam+1)-1
            cid  = pgcols(curgcol)%chunk
            owner_p  = chunks(cid)%owner
            if (iam == owner_p) then
               i    = pgcols(curgcol)%ccol
               lchnk = chunks(cid)%lchunk
               glon   = chunks(cid)%lon(i)
               glat   = chunks(cid)%lat(i)
               block_cnt = get_block_coord_cnt_d(glon,glat)
               call get_block_coord_d(glon,glat,block_cnt,blockids,bcids)
               do jb = 1,block_cnt
                  owner_d = get_block_owner_d(blockids(jb))
                  if (p == owner_d) then
                     numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb))
                     call get_block_levels_d(blockids(jb),bcids(jb),numlvl,levels)
                     do k=1,numlvl
                        btofc_chk_offset(lchnk)%pter(i,levels(k)+1) = glbcnt
                        curcnt = curcnt + 1
                        glbcnt = glbcnt + 1
                     enddo
                  endif
               enddo
            endif
         enddo
         btofc_chk_num(p) = curcnt
         curcnt = 0
      enddo
      chunk_buf_nrecs = glbcnt
   endif
!
   physgrid_set = .true.   ! Set flag indicating physics grid is now set
!
   return
   end subroutine phys_grid_init
!
!========================================================================
!
   subroutine get_chunk_indices_p(index_beg, index_end)
!----------------------------------------------------------------------- 
! 
! Purpose: Return range of indices for local chunks
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(out) :: index_beg  ! first index used for local chunks
   integer, intent(out) :: index_end  ! last index used for local chunks
!-----------------------------------------------------------------------

   index_beg = begchunk
   index_end = endchunk

   return
   end subroutine get_chunk_indices_p
!
!========================================================================
!
   integer function get_ncols_p(lchunkid)
!----------------------------------------------------------------------- 
! 
! Purpose: Return number of columns in chunk given the local chunk id.
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id

!---------------------------Local workspace-----------------------------
   integer              :: chunkid       ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   get_ncols_p = chunks(chunkid)%ncols

   return
   end function get_ncols_p
!
!========================================================================
!
   subroutine get_lat_all_p(lchunkid, latdim, lats)
!----------------------------------------------------------------------- 
! 
! Purpose: Return all global latitude indices for chunk
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id
   integer, intent(in)  :: latdim        ! declared size of output array

   integer, intent(out) :: lats(latdim)  ! array of global latitude indices

!---------------------------Local workspace-----------------------------
   integer :: i                          ! loop index
   integer :: chunkid                    ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   do i=1,chunks(chunkid)%ncols
     lats(i) = chunks(chunkid)%lat(i)
   enddo

   return
   end subroutine get_lat_all_p
!
!========================================================================

   subroutine get_lat_vec_p(lchunkid, lth, cols, lats)
!----------------------------------------------------------------------- 
! 
! Purpose: Return global latitude indices for set of chunk columns
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id
   integer, intent(in)  :: lth           ! number of column indices
   integer, intent(in)  :: cols(lth)     ! column indices

   integer, intent(out) :: lats(lth)     ! array of global latitude indices

!---------------------------Local workspace-----------------------------
   integer :: i                          ! loop index
   integer :: chunkid                    ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   do i=1,lth
     lats(i) = chunks(chunkid)%lat(cols(i))
   enddo

   return
   end subroutine get_lat_vec_p
!
!========================================================================

   integer function get_lat_p(lchunkid, col)
!----------------------------------------------------------------------- 
! 
! Purpose: Return global latitude index for chunk column
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id
   integer, intent(in)  :: col           ! column index

!---------------------------Local workspace-----------------------------
   integer :: chunkid                    ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   get_lat_p = chunks(chunkid)%lat(col)

   return
   end function get_lat_p
!
!========================================================================
!
   subroutine get_lon_all_p(lchunkid, londim, lons)
!----------------------------------------------------------------------- 
! 
! Purpose: Return all global longitude indices for chunk
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id
   integer, intent(in)  :: londim        ! declared size of output array

   integer, intent(out) :: lons(londim)  ! array of global longitude indices

!---------------------------Local workspace-----------------------------
   integer :: i                          ! loop index
   integer :: chunkid                    ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   do i=1,chunks(chunkid)%ncols
     lons(i) = chunks(chunkid)%lon(i)
   enddo

   return
   end subroutine get_lon_all_p
!
!========================================================================

   subroutine get_lon_vec_p(lchunkid, lth, cols, lons)
!----------------------------------------------------------------------- 
! 
! Purpose: Return global longitude indices for set of chunk columns
! 
! Method: 
! 
! Author: Patrick Worley
! 
!-----------------------------------------------------------------------
   use precision
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
   integer, intent(in)  :: lchunkid      ! local chunk id
   integer, intent(in)  :: lth           ! number of column indices
   integer, intent(in)  :: cols(lth)     ! column indices

   integer, intent(out) :: lons(lth)     ! array of global longitude indices

!---------------------------Local workspace-----------------------------
   integer :: i                          ! loop index
   integer :: chunkid                    ! global chunk id

!-----------------------------------------------------------------------
   chunkid = lchunks(lchunkid)
   do i=1,lth
     lons(i) = chunks(chunkid)%lon(cols(i))
   enddo

   return
   end subroutine get_lon_vec_p