!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
subroutine multicD (nproc,proc,myproc,type,mycol,iwk) 1
integer nproc,proc(nproc),myproc,type,mycol,iwk(*)
include 'mpif.h'
c-----------------------------------------------------------------------
c P-SPARSLIB ROUTINE MULTICD
c parallel node multicoloring. This code assigns a color to
c each processor such that no two neighboring processors are
c assigned the same color. The algorithm used is based on a topo-
c gical sorting of the upward directed version of the graph
c (i.e., graph obtained by orienting all edges from lower labels
c to higher labels). As in level scheduling, the parallelism is of
c the order of the diameter of the graph.
c
c written by Y. Saad, modified by A. Malevsky, January 25, 1995
c revision:
c Abdessamad Qaddouri: adds RPN_send and RPN_receiv
c
c-----------------------------------------------------------------------
c on entry:
c---------
c nproc = number of processors that are adjacent to my processor
c
c proc = list of the processors adajacent to my processor.
c
c myproc = label of my processor
c
c type = tag to be used for sends / receives.
c
c
c on return:
c ----------
c mycol = color assigned to my processor
c
c work space
c -----------
c iwk = integer whose size equal the maximum number of different
c colors assigned to adjacent processors/
c
c NOTE: processor ID's are supposed to be .ge. 1 in list proc.
c-----------------------------------------------------------------------
c****Feb 1996
c modified the code to allow nproc = 0
integer kol,ii,k,j,low,len,ncol,imsg
c
c
c if one processor is used or no adajacent processors at all
c return as mycol = 1
if(nproc.eq.0) then
mycol = 1
return
endif
kol=0
len = 1
c
c determine the processors with lower id's than mine
c
low = 1
1 if (proc(low) .lt. myproc) then
low = low+1
if (low .le. nproc) goto 1
endif
low = low - 1
ncol = 0
iwk(1) = 0
c
c receive all colors of neighbors
c
do 10 ii = 1, low
c call MSG_receive(proc(ii),type,kol,len,imsg)
c call MPI_BARRIER(MPI_COMM_WORLD,imsg)
call RPN_COMM_recv ( kol, 1, 'MPI_INTEGER',
$ proc(ii)-1,type,'grid',staus,ierr)
c
c sorted insertion -- first find where to insert
c
j = 1
2 if (j .le. ncol .and. iwk(j) .lt. kol) then
j = j+1
goto 2
else if (iwk(j) .eq. kol) then
goto 10
endif
j = j-1
c
do k= j+1,ncol,-1
iwk(k+1) = iwk(k)
enddo
iwk(j+1) = kol
ncol = ncol+1
10 continue
c
c determine my color by searching for a gap in iwk
c
mycol = 1
k = 1
3 if (iwk(k) .eq. mycol) then
k = k+1
mycol = mycol+1
if (k .le. ncol) goto 3
endif
do 20 ii = low+1, nproc
c call MSG_send(proc(ii),type,mycol,len,imsg)
call RPN_COMM_send ( mycol, 1, 'MPI_INTEGER', proc(ii)-1,
$ type, 'grid', ierr)
20 continue
return
c-----------------------------------------------------------------------
c-----end-of-multicD----------------------------------------------------
end