LCOV - code coverage report
Current view: | top level - dynamics/se/dycore - schedule_mod.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 259 | 331 | 78.2 %
Date: | 2024-12-17 22:39:59 |  | Functions: | 3 | 8 | 37.5 %

              Line data    Source code
           1             : module schedule_mod
           2             :   use metagraph_mod, only: MetaEdge_t
           3             :   use schedtype_mod, only: Cycle_t, Schedule_t, schedule, pgindex_t, HME_Ordinal,HME_Cardinal
           4             :   use parallel_mod,  only: parallel_t
           5             :   use cam_logfile,   only: iulog
           6             :
           7             :   implicit none
           8             :   private
           9             :
          10             :   type, public :: GraphStats_t
          11             :      integer :: offnode
          12             :      integer :: onnode
          13             :      integer :: LB
          14             :      integer :: padding
          15             :   end type GraphStats_t
          16             :
          17             :   integer,public,parameter :: HME_CYCLE_SEND=1
          18             :   integer,public,parameter :: HME_CYCLE_RECV=2
          19             :   integer,public,parameter :: HME_CYCLE_MOVE=3
          20             :   integer,public,parameter :: HME_CYCLE_ANY =4
          21             :
          22             :
          23             :   integer,public,parameter :: BNDRY_EXCHANGE_MESSAGE=10
          24             :   integer,private,allocatable,target  :: Global2Local(:)
          25             :
          26             :   integer :: MinNelemd,MaxNelemd
          27             :
          28             :   public :: genEdgeSched              ! Setup the communication schedule for the edge based boundary exchange
          29             :   public :: PrintSchedule, PrintCycle
          30             :   public :: PrintIndex
          31             :   public :: CheckSchedule
          32             :   public :: FindBufferSlot
          33             :
          34             : contains
          35             :
          36        1536 :   subroutine genEdgeSched(par,elem, PartNumber,LSchedule,MetaVertex)
          37             :     use element_mod,    only: element_t
          38             :     use metagraph_mod,  only: metavertex_t
          39             :     use dimensions_mod, only: nelem, max_neigh_edges
          40             :     use gridgraph_mod,  only: gridvertex_t, gridedge_t, assignment ( = )
          41             :     use cam_abortutils, only: endrun
          42             :     use spmd_utils,     only: mpi_status_size, mpi_info_null, mpi_success
          43             :     use parallel_mod,   only: nComPoints, rrequest, srequest, status, npackpoints
          44             :
          45             :     type(parallel_t),    intent(inout) :: par
          46             :     type(element_t),     intent(inout) :: elem(:)
          47             :     integer,             intent(in)    :: PartNumber
          48             :     type (schedule_t),   intent(inout) :: LSchedule
          49             :     type (MetaVertex_t), intent(inout) :: MetaVertex
          50             :
          51             :     integer                       :: lengthP,lengthS,total_length,lengthp_ghost
          52             :     integer                       :: i,j,is,ir,ncycle
          53             :     integer                       :: il,ie,ig
          54             :     integer                       :: nelemd0
          55             :     integer                       :: jmd
          56             :     integer                       :: inbr
          57             :     integer                       :: nSched
          58        1536 :     integer,allocatable           :: tmpP(:,:)
          59        1536 :     integer,allocatable           :: tmpS(:,:)
          60        1536 :     integer,allocatable           :: tmpP_ghost(:,:)
          61             :     integer                       :: nSend,nRecv,nedges
          62             :     integer                       :: icycle
          63             :     integer           :: iSched
          64             :     logical, parameter            :: VerbosePrint=.FALSE.
          65             :     logical, parameter            :: Debug=.FALSE.
          66             :     character(len=*),       parameter :: subname = 'genEdgeSched'
          67             :     integer                           :: errorcode,errorlen
          68             :     character*(80)                    :: errorstring
          69             :     integer, allocatable :: intracommranks(:)
          70             :     integer :: numIntra, numInter, rank
          71             :     logical :: OnNode
          72             :
          73             :
          74             :     integer :: ierr
          75             :     integer :: l1,l2,l1id,l2id
          76             :     integer :: src,dest,wgt
          77             :     integer :: icIntra, icInter
          78             :
          79        1536 :     integer, allocatable :: srcFull(:), destFull(:),  srcweightFull(:), destweightFull(:)
          80        1536 :     integer, allocatable :: srcInter(:),destInter(:), srcweightInter(:),destweightInter(:)
          81        1536 :     integer, allocatable :: srcIntra(:),destIntra(:), srcweightIntra(:),destweightIntra(:)
          82             :
          83             :     logical :: reorder
          84             :     integer :: sizeGroup, groupFull
          85             :
          86        1536 :     nSched=SIZE(schedule)
          87             :     ! ================================================
          88             :     ! allocate some arrays for the call to MPI_gatherv
          89             :     ! ================================================
          90             :
          91        1536 :     MinNelemd = nelem
          92        1536 :     MaxNelemd = 0
          93             :     ! =====================================================
          94             :     ! It looks like this is only used in this routine...
          95             :     ! so no need to put it in the schedule data-structure
          96             :     ! =====================================================
          97        4608 :     allocate(Global2Local(nelem))
          98             :     if(Debug) write(iulog,*)'genEdgeSched: point #1'
          99        1536 :     iSched = PartNumber
         100             :
         101        1536 :     nelemd0 = MetaVertex%nmembers
         102        1536 :     MaxNelemd = AMAX0(MaxNelemd,nelemd0)
         103        1536 :     MinNelemd = AMIN0(MinNelemd,nelemd0)
         104             :     if(Debug) write(iulog,*)'genEdgeSched: point #2'
         105             :
         106             :     if(Debug) write(iulog,*)'genEdgeSched: point #3'
         107        1536 :     LSchedule%ncycles = MetaVertex%nedges
         108        1536 :     LSchedule%nelemd  = nelemd0
         109             :     if(Debug) write(iulog,*)'genEdgeSched: point #4'
         110             :
         111             :     !  Note the minus one is for the internal node
         112        1536 :     nedges = MetaVertex%nedges
         113        1536 :     if(2*(nedges/2) .eq. nedges) then
         114             :        nedges = nedges/2
         115             :     else
         116        1536 :        nedges = (nedges-1)/2
         117             :     endif
         118        1536 :     LSchedule%nSendCycles = nedges
         119        1536 :     LSchedule%nRecvCycles = nedges
         120             :     if(Debug) write(iulog,*)'genEdgeSched: point #5'
         121             :
         122             :     ! Temporary array to calculate the Buffer Slot
         123        4608 :     allocate(tmpP(2,nedges+1))
         124        3072 :     allocate(tmpS(2,nedges+1))
         125        3072 :     allocate(tmpP_ghost(2,nedges+1))
         126             :
         127             :
         128             :     !  Allocate all the cycle structures
         129        4608 :     allocate(LSchedule%SendCycle(nedges))
         130        3072 :     allocate(LSchedule%RecvCycle(nedges))
         131        1536 :     allocate(LSchedule%MoveCycle(1))
         132             :
         133             :     ! Initialize the schedules...
         134        1536 :     LSchedule%MoveCycle(1)%ptrP = 0
         135        1536 :     LSchedule%MoveCycle(1)%ptrS = 0
         136        1536 :     LSchedule%MoveCycle(1)%lengthP = 0
         137             :     if(Debug) write(iulog,*)'genEdgeSched: point #6'
         138             :
         139             :     !==================================================================
         140             :     !  Allocate and initalized the index translation arrays
         141     8295936 :     Global2Local = -1
         142        4608 :     allocate(LSchedule%Local2Global(nelemd0))
         143        4608 :     allocate(LSchedule%pIndx(max_neigh_edges*nelemd0))
         144        3072 :     allocate(LSchedule%gIndx(max_neigh_edges*nelemd0))
         145             :
         146       87936 :     LSchedule%pIndx(:)%elemId   = -1
         147       87936 :     LSchedule%pIndx(:)%edgeId   = -1
         148       87936 :     LSchedule%pIndx(:)%lenP     = -1
         149       87936 :     LSchedule%pIndx(:)%lenS     = -1
         150       87936 :     LSchedule%pIndx(:)%mesgid   = -1
         151       87936 :     LSchedule%pIndx(:)%edgeType = -1
         152             :
         153       87936 :     LSchedule%gIndx(:)%elemId   = -1
         154       87936 :     LSchedule%gIndx(:)%edgeId   = -1
         155       87936 :     LSchedule%gIndx(:)%lenP     = -1
         156       87936 :     LSchedule%gIndx(:)%lenS     = -1
         157       87936 :     LSchedule%gIndx(:)%mesgid   = -1
         158       87936 :     LSchedule%gIndx(:)%edgeType = -1
         159             :
         160        1536 :     LSchedule%pPtr=1
         161        1536 :     LSchedule%gPtr=1
         162             :
         163             :     if(Debug) write(iulog,*)'genEdgeSched: point #7'
         164             :
         165       12336 :     do il=1,nelemd0
         166       10800 :        ig     = MetaVertex%members(il)%number
         167       10800 :        Global2Local(ig)=il
         168       10800 :        LSchedule%Local2Global(il)=ig
         169       97200 :        elem(il)%desc%putmapP=-1
         170       97200 :        elem(il)%desc%getmapP=-1
         171       97200 :        elem(il)%desc%putmapS=-1
         172       97200 :        elem(il)%desc%getmapS=-1
         173       97200 :        elem(il)%desc%putmapP_ghost=-1
         174       97200 :        elem(il)%desc%getmapP_ghost=-1
         175       98736 :        elem(il)%desc%reverse = .FALSE.
         176             :     enddo
         177             :     !==================================================================
         178             :     if(Debug) write(iulog,*)'genEdgeSched: point #8'
         179             :
         180             :
         181             :
         182        1536 :     total_length = 0
         183        1536 :     ncycle = LSchedule%ncycles
         184             :     !
         185             :     ! Send Cycle
         186             :     !
         187        1536 :     is=1
         188       12964 :     tmpP(1,:) = -1
         189       12964 :     tmpP(2,:) = 0
         190       12964 :     tmpS(1,:) = -1
         191       12964 :     tmpS(2,:) = 0
         192       12964 :     tmpP_ghost(1,:) = -1
         193       12964 :     tmpP_ghost(2,:) = 0
         194             :
         195       22856 :     do j=1,ncycle
         196       21320 :        lengthP     =  MetaVertex%edges(j)%wgtP
         197       21320 :        lengthS     =  MetaVertex%edges(j)%wgtS
         198       21320 :        lengthP_ghost     =  MetaVertex%edges(j)%wgtP_ghost
         199             :
         200       21320 :        if ((MetaVertex%edges(j)%TailVertex == PartNumber) .AND. &
         201        1536 :                 (MetaVertex%edges(j)%HeadVertex .ne. PartNumber) ) then
         202        9892 :           inbr                            = MetaVertex%edges(j)%HeadVertex
         203             :           if(Debug) write(iulog,*)'genEdgeSched: point #11', par%rank
         204        9892 :           LSchedule%SendCycle(is)%ptrP     = FindBufferSlot(inbr,lengthP,tmpP)
         205        9892 :           LSchedule%SendCycle(is)%ptrS     = FindBufferSlot(inbr,lengthS,tmpS)
         206        9892 :           LSchedule%SendCycle(is)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
         207        9892 :           call SetCycle(par, elem, LSchedule,LSchedule%SendCycle(is),MetaVertex%edges(j), HME_CYCLE_SEND)
         208             :           if(Debug) write(iulog,*)'genEdgeSched: point #12',par%rank
         209        9892 :           is = is+1
         210             :        endif
         211             :     enddo
         212             :
         213             :     !
         214             :     ! Recv Cycle:  Note that by reinitializing the tmpP array we change the structure of the receive buffer
         215             :     !
         216        1536 :     ir=1
         217       12964 :     tmpP(1,:) = -1
         218       12964 :     tmpP(2,:) = 0
         219       12964 :     tmpS(1,:) = -1
         220       12964 :     tmpS(2,:) = 0
         221       12964 :     tmpP_ghost(1,:) = -1
         222       12964 :     tmpP_ghost(2,:) = 0
         223             :
         224       22856 :     do j=1,ncycle
         225       21320 :        lengthP     =  MetaVertex%edges(j)%wgtP
         226       21320 :        lengthS     =  MetaVertex%edges(j)%wgtS
         227       21320 :        lengthP_ghost     =  MetaVertex%edges(j)%wgtP_ghost
         228             :
         229       21320 :        if ( (MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
         230        1536 :                (MetaVertex%edges(j)%TailVertex .ne. PartNumber) ) then
         231        9892 :           inbr                            = MetaVertex%edges(j)%TailVertex
         232             :           if(Debug) write(iulog,*)'genEdgeSched: point #13',par%rank
         233        9892 :           LSchedule%RecvCycle(ir)%ptrP     = FindBufferSlot(inbr,lengthP,tmpP)
         234        9892 :           LSchedule%RecvCycle(ir)%ptrS     = FindBufferSlot(inbr,lengthS,tmpS)
         235        9892 :           LSchedule%RecvCycle(ir)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
         236        9892 :           call SetCycle(par, elem, LSchedule,LSchedule%RecvCycle(ir),MetaVertex%edges(j),HME_CYCLE_RECV)
         237             :           if(Debug) write(iulog,*)'genEdgeSched: point #14',par%rank
         238        9892 :           ir = ir+1
         239             :        endif
         240             :     enddo
         241             :
         242             :     ! Put the move cycle at the end of the buffer.
         243       22856 :     do j=1,ncycle
         244       21320 :        lengthP     =  MetaVertex%edges(j)%wgtP
         245       21320 :        lengthS     =  MetaVertex%edges(j)%wgtS
         246       21320 :        lengthP_ghost     =  MetaVertex%edges(j)%wgtP_ghost
         247             :
         248       21320 :        if((MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
         249        1536 :             (MetaVertex%edges(j)%TailVertex == PartNumber)) then
         250        1536 :           inbr                            = PartNumber
         251             :           if(Debug) write(iulog,*)'genEdgeSched: point #9', par%rank
         252        3072 :           LSchedule%MoveCycle%ptrP         = FindBufferSlot(inbr,lengthP,tmpP)
         253        3072 :           LSchedule%MoveCycle%ptrS         = FindBufferSlot(inbr,lengthS,tmpS)
         254        3072 :           LSchedule%MoveCycle%ptrP_ghost   = FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
         255        1536 :           call SetCycle(par, elem, LSchedule,LSchedule%MoveCycle(1),MetaVertex%edges(j),HME_CYCLE_MOVE)
         256             :           if(Debug) write(iulog,*)'genEdgeSched: point #10',par%rank
         257             :        endif
         258             :     enddo
         259             :
         260        1536 :     deallocate(tmpP)
         261        1536 :     deallocate(tmpS)
         262        1536 :     deallocate(tmpP_ghost)
         263             :
         264       12336 :     do ie=1,nelemd0
         265             :        ! compute number of neighbers for each element
         266       10800 :        elem(ie)%desc%actual_neigh_edges=0
         267       97200 :        do i=1,max_neigh_edges
         268       97200 :           if (elem(ie)%desc%globalID(i)>0) then
         269       86352 :              elem(ie)%desc%actual_neigh_edges=elem(ie)%desc%actual_neigh_edges+1
         270             :           endif
         271             :        enddo
         272             :
         273             :        ! normally, we loop over max_neigh_edges, checking if there is an edge
         274             :        ! let's create a mapping so that we can loop over actual_neigh_edges
         275             :        ! sort in REVERSE global id order (so the ones with globalID=0 are last)
         276       86400 :        do l1 = 1,max_neigh_edges-1
         277      388800 :           do l2=l1+1,max_neigh_edges
         278      302400 :              l1id=elem(ie)%desc%loc2buf(l1)
         279      302400 :              l2id=elem(ie)%desc%loc2buf(l2)
         280      378000 :              if (elem(ie)%desc%globalID(l2id) > elem(ie)%desc%globalID(l1id)) then
         281             :                 ! swap index:
         282      191132 :                 l1id=elem(ie)%desc%loc2buf(l2)
         283      191132 :                 elem(ie)%desc%loc2buf(l2)=elem(ie)%desc%loc2buf(l1)
         284      191132 :                 elem(ie)%desc%loc2buf(l1)=l1id
         285             :              endif
         286             :           enddo
         287             :        enddo
         288             :
         289             :
         290             :
         291             :
         292       10800 :        elem(ie)%vertex     = MetaVertex%members(ie)
         293       10800 :        ig                  = MetaVertex%members(ie)%number
         294       10800 :        elem(ie)%GlobalId   = ig
         295       23136 :        elem(ie)%LocalId    = ie
         296             :     enddo
         297             :
         298        1536 :     deallocate(Global2Local)
         299             :
         300             : #ifdef SPMD
         301             :     !================================================================
         302             :     !     Allocate a couple of structures for bndry_exchange
         303             :     !        done here to remove it from the critical path
         304             :     !================================================================
         305        1536 :     nComPoints = 0
         306             :
         307        1536 :     nSend = nedges
         308        1536 :     nRecv = nedges
         309        4608 :     allocate(Rrequest(nRecv))
         310        3072 :     allocate(Srequest(nSend))
         311        4608 :     allocate(status(MPI_STATUS_SIZE,nRecv))
         312             :
         313             :     !===============================================================
         314             :     !   Number of communication points ... to be used later to
         315             :     !    setup the size of the communication buffer for MPI_Ibsend
         316             :     !===============================================================
         317       11428 :     do icycle = 1, nSend
         318       11428 :       nComPoints = nComPoints + LSchedule%SendCycle(icycle)%lengthP
         319             :     end do
         320        1536 :     nPackPoints = nComPoints + LSchedule%MoveCycle(1)%lengthP
         321             : #if MPI_VERSION >= 3
         322             :    ! Create a communicator that only contains the on-node MPI ranks
         323             :    call MPI_Comm_split_type(par%comm, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, par%intracomm, ierr)
         324             :
         325             :    call MPI_Comm_size(par%intracomm, par%intracommsize, ierr)
         326             :    call MPI_Comm_rank(par%intracomm, par%intracommrank, ierr)
         327             :
         328             :    allocate(intracommranks(par%intracommsize))
         329             :    call MPI_Allgather(par%rank,1,MPIinteger_t,intracommranks,1,MPIinteger_t,par%intracomm,ierr)
         330             :
         331             :    numIntra=0
         332             :    do icycle=1,nSend
         333             :       rank = LSchedule%SendCycle(icycle)%dest - 1
         334             :       onNode = isIntraComm(intracommranks,rank)
         335             :       LSchedule%SendCycle(icycle)%onNode = onNode
         336             :       if(onNode) then
         337             :          numIntra=numIntra+1
         338             :       endif
         339             :    enddo
         340             :    do icycle=1,nRecv
         341             :       rank = LSchedule%RecvCycle(icycle)%source - 1
         342             :       onNode = isIntraComm(intracommranks,rank)
         343             :       LSchedule%RecvCycle(icycle)%onNode = onNode
         344             :    enddo
         345             :    numInter = nsend-numIntra
         346             :
         347             :
         348             :    deallocate(intracommranks)
         349             : #else
         350        1536 :    numIntra = 0
         351        1536 :    numInter = nSend
         352             :    ! Mark all communications as off-node by default
         353       11428 :    do icycle=1,nSend
         354       11428 :       LSchedule%SendCycle(icycle)%onNode = .False.
         355             :    enddo
         356       11428 :    do icycle=1,nRecv
         357       11428 :       LSchedule%RecvCycle(icycle)%onNode = .False.
         358             :    enddo
         359             : #endif
         360        1536 :     LSchedule%nInter = numInter
         361        1536 :     LSchedule%nIntra = numIntra
         362             :
         363        7680 :     allocate(srcFull(nRecv), srcWeightFull(nRecv),destFull(nSend),destWeightFull(nSend))
         364        1536 :     if(numInter>0) then
         365        7680 :       allocate(srcInter(numInter),srcWeightInter(numInter),destInter(numInter), destWeightInter(numInter))
         366             :     endif
         367             :     if(numIntra>0) then
         368             :       allocate(srcIntra(numIntra),srcWeightIntra(numIntra),destIntra(numIntra), destWeightIntra(numIntra))
         369             :     endif
         370             :
         371             :     icIntra=0
         372             :     icInter=0
         373       11428 :     do icycle=1,nSend
         374        9892 :        dest = LSchedule%SendCycle(icycle)%dest - 1
         375        9892 :        wgt  = LSchedule%SendCycle(icycle)%lengthP
         376        9892 :        destFull(icycle) = dest
         377        9892 :        destWeightFull(icycle) = wgt
         378       11428 :        if(LSchedule%SendCycle(icycle)%onNode) then
         379           0 :           icIntra=icIntra+1
         380           0 :           destIntra(icIntra) = dest
         381           0 :           destWeightIntra(icIntra) = wgt
         382             :        else
         383        9892 :           icInter=icInter+1
         384        9892 :           destInter(icInter) = dest
         385        9892 :           destWeightInter(icInter) = wgt
         386             :        endif
         387             :     enddo
         388             :
         389        1536 :     icIntra=0
         390        1536 :     icInter=0
         391       11428 :     do icycle=1,nRecv
         392        9892 :        src = LSchedule%RecvCycle(icycle)%source - 1
         393        9892 :        wgt = LSchedule%RecvCycle(icycle)%lengthP
         394        9892 :        srcFull(icycle) = src
         395        9892 :        srcWeightFUll(icycle) = wgt
         396       11428 :        if(LSchedule%RecvCycle(icycle)%onNode) then
         397           0 :           icIntra=icIntra+1
         398           0 :           srcIntra(icIntra) = src
         399           0 :           srcWeightIntra(icIntra) = wgt
         400             :        else
         401        9892 :           icInter=icInter+1
         402        9892 :           srcInter(icInter) = src
         403        9892 :           srcWeightInter(icInter) = wgt
         404             :        endif
         405             :     enddo
         406             :
         407             :     ! construct the FULL communication graph
         408        1536 :     reorder=.FALSE.
         409             :     call MPI_Dist_graph_create_adjacent(par%comm, nRecv,srcFull,srcWeightFull, &
         410        1536 :          nSend,destFull,destWeightFull,MPI_INFO_NULL,reorder,par%commGraphFull,ierr)
         411        1536 :     if(ierr .ne. MPI_SUCCESS) then
         412           0 :        errorcode=ierr
         413           0 :        call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
         414           0 :        print *,subname,': Error after call to MPI_dist_graph_create_adjacent(FULL) ',errorstring
         415             :     endif
         416        7680 :     allocate(LSchedule%destFull(nSend),LSchedule%srcFull(nRecv))
         417       11428 :     LSchedule%destFull(:) = destFull(:)
         418       11428 :     LSchedule%srcFull(:)  = srcFull(:)
         419             :     ! construct the FULL communication -group- (for one-sided operations):
         420        1536 :     call MPI_Comm_group(par%comm, groupFull, ierr)
         421        1536 :     call MPI_group_incl(groupFull,nRecv,srcFull,par%groupGraphFull,ierr)
         422        1536 :     if (ierr .ne. MPI_SUCCESS) then
         423           0 :        errorcode=ierr
         424           0 :        call MPI_Error_String(errorcode, errorstring, errorlen, ierr)
         425           0 :        print *,subname, ': Error after call to MPI_Comm_group (groupGraphFull) ', errorstring
         426             :     endif
         427        1536 :     call MPi_Group_size(par%groupGraphFull,sizeGroup,ierr)
         428             :     if(Debug) write (*,199) par%rank,sizeGroup,nSend,nRecv
         429             :
         430             : 199 format ('RANK: ',i4,' genEdgeSched: size of groupGraphFUll is: ',i8,' nSend, nRecv: ',2(i4))
         431        1536 :     deallocate(srcFull,srcWeightFull,destFull,destWeightFull)
         432             :
         433             :     ! construct the INTER communication graph
         434        1536 :     reorder=.FALSE.
         435        1536 :     if(numInter>0) then
         436             :        call MPI_Dist_graph_create_adjacent(par%comm, numInter,srcInter,srcWeightInter, &
         437        1536 :          numInter,destInter,destWeightInter,MPI_INFO_NULL,reorder,par%commGraphInter,ierr)
         438        1536 :        if(ierr .ne. MPI_SUCCESS) then
         439           0 :           errorcode=ierr
         440           0 :           call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
         441           0 :           print *,subname,': Error after call to MPI_dist_graph_create_adjacent(INTER) ',errorstring
         442             :        endif
         443        1536 :        deallocate(srcInter,srcWeightInter,destInter,destWeightInter)
         444             :     endif
         445             :
         446             :     ! construct the INTRA communication graph
         447        1536 :     reorder=.FALSE.
         448        1536 :     if(numIntra>0) then
         449             :        call MPI_Dist_graph_create_adjacent(par%comm, numIntra,srcIntra,srcWeightIntra, &
         450           0 :          numIntra,destIntra,destWeightIntra,MPI_INFO_NULL,reorder,par%commGraphIntra,ierr)
         451           0 :        if(ierr .ne. MPI_SUCCESS) then
         452           0 :           errorcode=ierr
         453           0 :           call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
         454           0 :           print *,subname,': Error after call to MPI_dist_graph_create_adjacent(INTRA) ',errorstring
         455             :        endif
         456           0 :        deallocate(srcIntra,srcWeightIntra,destIntra,destWeightIntra)
         457             :     endif
         458             :
         459             :   200 format ('IAM: ',i4,': ', i2,' of',i2,' comms are interNode')
         460             :   201 format ('IAM: ',i4,': ', i2,' of',i2,' comms are intraNode')
         461             : #endif
         462             :
         463             :
         464        1536 :   end subroutine genEdgeSched
         465             :
         466             :   logical function isIntraComm(commranks,rank)
         467             :
         468             :
         469             :     integer, intent(in) :: commranks(:)
         470             :     integer, intent(in) :: rank
         471             :
         472             :     integer :: i,nranks
         473             :
         474             :     nranks = SIZE(commranks)
         475             :     isIntraComm = .FALSE.
         476             :     do i=1,nranks
         477             :         if(commranks(i) .eq. rank) then
         478             :            isIntraComm=.TRUE.
         479             :         endif
         480             :     enddo
         481             :
         482             :   end function isIntraComm
         483             :
         484           0 :   subroutine CheckSchedule()
         485             :
         486             :     integer                    :: i, nSched, nbufferwords_1, nbufferwords_2
         487             :     type (Schedule_t), pointer :: pSchedule
         488             :
         489           0 :     nSched = SIZE(Schedule)
         490             :
         491           0 :     do i = 1, nSched
         492           0 :       pSchedule => Schedule(i)
         493           0 :       nbufferwords_1 = SUM(pSchedule%SendCycle(:)%lengthP)
         494           0 :       nbufferwords_2 = SUM(pSchedule%RecvCycle(:)%lengthP)
         495           0 :       if(nbufferwords_1 .ne. nbufferwords_2) then
         496           0 :         write (iulog,100) i,nbufferwords_1, nbufferwords_2
         497             :       end if
         498             :     end do
         499             : 100 format('CheckSchedule: ERR IAM:',I3,' SIZEOF(SendBuffer):',I10,' != SIZEOF(RecvBuffer) :',I10)
         500             :
         501           0 :   end subroutine CheckSchedule
         502             :
         503           0 :   subroutine PrintSchedule(Schedule)
         504             :     ! Debug subroutine for the schedule_t data-structure
         505             :     use gridgraph_mod, only : printgridedge
         506             :
         507             :     type (Schedule_t),intent(in),target   :: Schedule(:)
         508             :     type (Schedule_t), pointer            :: pSchedule
         509             :     type (Cycle_t),pointer                :: pCycle
         510             :
         511             :     integer               :: i,j,nSched
         512             :
         513           0 :     nSched = SIZE(Schedule)
         514             :
         515           0 :     write(6,*) '------NEW SCHEDULE FORMAT---------------------'
         516           0 :     do i=1,nSched
         517           0 :        pSchedule => Schedule(i)
         518           0 :        write(6,*)
         519           0 :        write(6,*) '----------------------------------------------'
         520           0 :        write(6,90) i,pSchedule%ncycles
         521           0 :        write(6,*) '----------------------------------------------'
         522           0 :        write(6,*) '-----------SEND-------------------------------'
         523           0 :        do j=1,pSchedule%nSendCycles
         524           0 :           pCycle => pSchedule%SendCycle(j)
         525           0 :           call PrintCycle(pCycle)
         526           0 :           call PrintGridEdge(pCycle%edge%members)
         527             :        enddo
         528           0 :        write(6,*) '-----------RECV-------------------------------'
         529           0 :        do j=1,pSchedule%nRecvCycles
         530           0 :           pCycle => pSchedule%RecvCycle(j)
         531           0 :           call PrintCycle(pCycle)
         532           0 :           call PrintGridEdge(pCycle%edge%members)
         533             :        enddo
         534           0 :        write(6,*) '-----------MOVE-------------------------------'
         535           0 :        pCycle => pSchedule%MoveCycle(1)
         536           0 :        call PrintCycle(pCycle)
         537           0 :        call PrintGridEdge(pCycle%edge%members)
         538             :     enddo
         539           0 :     write(6,*) '-----------Put Index--------------------'
         540           0 :     call PrintIndex(Schedule(1)%pIndx)
         541           0 :     write(6,*) '-----------Get Index--------------------'
         542             :     call PrintIndex(Schedule(1)%gIndx)
         543             :
         544             : 90  format('NODE # ',I2,2x,'NCYCLES ',I2)
         545             : 97  format(10x,'EDGE #',I2,2x,'TYPE ',I1,2x,'G.EDGES',I4,2x,'WORDS ',I5,2x, &
         546             :          'SRC ',I3,2x,'DEST ',I3,2x,'PTR ',I4)
         547             : 100 format(15x,I4,5x,I3,1x,'(',I1,') --',I1,'--> ',I3,1x,'(',I1,')')
         548             :
         549           0 :   end subroutine PrintSchedule
         550             :
         551           0 :   subroutine PrintIndex(Indx)
         552             :   ! Debugging subroutine for the pgindex_t data-structure
         553             :
         554             :     !  type, public :: pgindex_t
         555             :     !     integer :: elemid
         556             :     !     integer :: edgeid
         557             :     !     integer :: mesgid
         558             :     !     integer :: lenP,lenS
         559             :     !  end type pgindex_t
         560             :
         561             :     type (pgindex_t) :: Indx(:)
         562             :
         563             :     integer :: i, len
         564             :
         565           0 :     len = SIZE(Indx)
         566             :
         567           0 :     write(6,*) ' elemID,  edgeID,  mesgID, lenP, lenS '
         568           0 :     do i=1,len
         569           0 :        write(6,1099) Indx(i)%elemid,Indx(i)%edgeid,Indx(i)%mesgid,Indx(i)%lenP,Indx(i)%lenS
         570             :     enddo
         571             :
         572             : 1099 format(I4,5X,I4,5X,I4,5X,I2,4X,I2)
         573             :
         574           0 :   end subroutine PrintIndex
         575             :
         576           0 :   subroutine PrintCycle(Cycle)
         577             :   ! debug subroutine for the cycle_t data-structure
         578             :     type (Cycle_t),intent(in),target  ::  Cycle
         579             :
         580           0 :     write(6,97) Cycle%edge%number,Cycle%type,Cycle%edge%nmembers, &
         581           0 :          Cycle%lengthP,Cycle%source, Cycle%dest,Cycle%ptrP
         582             :
         583             : 97  format(5x,'METAEDGE #',I2,2x,'TYPE ',I1,2x,'G.EDGES',I4,2x,'WORDS ',I5,2x, &
         584             :          'SRC ',I3,2x,'DEST ',I3,2x,'PTR ',I5)
         585             :
         586           0 :   end subroutine PrintCycle
         587             :
         588       21320 :   subroutine SetCycle(par, elem, schedule,Cycle,Edge,ctype)
         589             :     use element_mod,    only: element_t
         590             :     use dimensions_mod, only: max_corner_elem, max_neigh_edges
         591             :     use cam_abortutils, only: endrun
         592             :
         593             :     type(parallel_t),  intent(in)         :: par
         594             :     type(element_t),   intent(inout)      :: elem(:)
         595             :     type (Schedule_t), intent(inout)      :: Schedule
         596             :     type (Cycle_t),    intent(inout)      :: Cycle
         597             :     type (MetaEdge_t), intent(in), target :: Edge
         598             :     integer,           intent(in)         :: ctype
         599             :     integer                               :: i,il,face, loc, dir
         600             :
         601      155488 :     do i = 1, Edge%nmembers
         602             :       if((ctype == HME_CYCLE_SEND) .or. &
         603      134168 :          (ctype == HME_CYCLE_MOVE) .or. &
         604             :          (ctype == HME_CYCLE_ANY)) then
         605             :         !   Setup send index
         606       86352 :         il                     = Global2Local(Edge%members(i)%tail%number)
         607       86352 :         face                   = Edge%members(i)%tail_face
         608             :         !need to convert the location of corner elements for getmap and putmap
         609       86352 :         if (face.ge.5) then ! if a corner element
         610       43152 :           dir = Edge%members(i)%tail_dir
         611       43152 :           loc = MOD(dir,max_corner_elem) !this is the location within that direction
         612       43152 :           dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
         613       43152 :           loc = dir + (dir-5)*(max_corner_elem-1)+loc
         614             :         else
         615             :           loc = face
         616             :         end if
         617             :
         618       86352 :         if(il .gt. 0) then
         619       86352 :           elem(il)%desc%putmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1  ! offset, so start at 0
         620       86352 :           elem(il)%desc%putmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
         621       86352 :           elem(il)%desc%putmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost  ! index, start at 1
         622       86352 :           elem(il)%desc%reverse(loc) = Edge%members(i)%reverse
         623       86352 :           schedule%pIndx(schedule%pPtr)%elemid=il
         624       86352 :           schedule%pIndx(schedule%pPtr)%edgeid=loc
         625       86352 :           schedule%pIndx(schedule%pPtr)%mesgid=Edge%HeadVertex-1  ! convert this to 0-based
         626       86352 :           schedule%pIndx(schedule%pPtr)%lenP  =Edge%members(i)%wgtP
         627       86352 :           schedule%pIndx(schedule%pPtr)%lenS  =Edge%members(i)%wgtS
         628       86352 :           if (face.ge.5) then
         629       43152 :              schedule%pIndx(schedule%pPtr)%edgeType = HME_Ordinal
         630             :           else
         631       43200 :              schedule%pIndx(schedule%pPtr)%edgeType = HME_Cardinal
         632             :           endif
         633       86352 :           schedule%pPtr=schedule%pPtr+1
         634             :         end if
         635             :       end if
         636             :
         637             :       if((ctype == HME_CYCLE_RECV) .or. &
         638      134168 :          (ctype == HME_CYCLE_MOVE) .or. &
         639       21320 :          (ctype == HME_CYCLE_ANY)) then
         640             :         !   Setup receive index
         641       86352 :         il                     = Global2Local(Edge%members(i)%head%number)
         642       86352 :         face                   = Edge%members(i)%head_face
         643             :         !need to convert the location of corner elements for getmap and putmap
         644       86352 :         if (face.ge.5) then !its a corner
         645       43152 :           dir = Edge%members(i)%head_dir
         646       43152 :           loc = MOD(dir,max_corner_elem) !this is the location within that direction
         647       43152 :           dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
         648       43152 :           loc = dir + (dir-5)*(max_corner_elem-1)+loc
         649       43152 :           if(loc > max_neigh_edges) then
         650           0 :             write(iulog, *) __FILE__,__LINE__,par%rank,face,i,max_corner_elem,max_neigh_edges,edge%members(i)%head_face
         651           0 :             call endrun('max_neigh_edges set too low.')
         652             :           end if
         653             :         else
         654             :           loc = face
         655             :         end if
         656             :
         657       86352 :         if(il .gt. 0) then
         658       86352 :           elem(il)%desc%getmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1
         659       86352 :           elem(il)%desc%getmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
         660       86352 :           elem(il)%desc%getmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost
         661       86352 :           elem(il)%desc%globalID(loc) = Edge%members(i)%tail%number
         662       86352 :           schedule%gIndx(schedule%gPtr)%elemid=il
         663       86352 :           schedule%gIndx(schedule%gPtr)%edgeid=loc
         664       86352 :           schedule%gIndx(schedule%gPtr)%mesgid=Edge%TailVertex-1  ! convert this to 0-based
         665       86352 :           schedule%gIndx(schedule%gPtr)%lenP  =Edge%members(i)%wgtP
         666       86352 :           schedule%gIndx(schedule%gPtr)%lenS  =Edge%members(i)%wgtS
         667       86352 :           if (face.ge.5) then
         668       43152 :              schedule%gIndx(schedule%gPtr)%edgeType = HME_Ordinal
         669             :           else
         670       43200 :              schedule%gIndx(schedule%gPtr)%edgeType = HME_Cardinal
         671             :           endif
         672       86352 :           schedule%gPtr=schedule%gPtr+1
         673             :         end if
         674             :       end if
         675             :     end do
         676       21320 :     Cycle%edge   => Edge
         677       21320 :     Cycle%type   = Edge%type
         678       21320 :     Cycle%dest   = Edge%HeadVertex
         679       21320 :     Cycle%source = Edge%TailVertex
         680       21320 :     Cycle%tag    = BNDRY_EXCHANGE_MESSAGE
         681       21320 :     Cycle%lengthP = Edge%wgtP
         682       21320 :     Cycle%lengthS = Edge%wgtS
         683       21320 :     Cycle%lengthP_ghost = Edge%wgtP_ghost
         684             :
         685       21320 :   end subroutine SetCycle
         686             :
         687       63960 :   function FindBufferSlot(inbr,length,tmp) result(ptr)
         688             :
         689             :     integer                :: ptr
         690             :     integer, intent(in)    :: inbr,length
         691             :     integer, intent(inout) :: tmp(:,:)
         692             :
         693             :     integer                :: i,n
         694             :
         695       63960 :     n = SIZE(tmp,2)
         696             :
         697       63960 :     ptr = 0
         698      260772 :     do i=1,n
         699      260772 :        if( tmp(1,i) == inbr) then
         700           0 :           ptr = tmp(2,i)
         701           0 :           return
         702             :        endif
         703      260772 :        if( tmp(1,i) == -1 ) then
         704       63960 :           tmp(1,i) = inbr
         705       63960 :           if(i .eq. 1) tmp(2,i) = 1
         706       63960 :           ptr = tmp(2,i)
         707       63960 :           if(i .ne. n) tmp(2,i+1) = ptr +length
         708       63960 :           return
         709             :        endif
         710             :     enddo
         711             :
         712             :   end function FindBufferSlot
         713             :
         714           0 : end module schedule_mod

Generated by: LCOV version 1.14