!-------------------------------------- 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 --------------------------------------
***s/r  multi_dom -  node muticoloring for LAM and global
*
#include "model_macros_f.h"

      subroutine multicl_dom (ncol,mycol)          1,1
      implicit none
*
      integer ncol,mycol
*
*author
*     Abdessamad Qaddouri  - initial version _ Decembre 2006 
*
*revision
* v3_30 - Qaddouri A.       - initial version
*
#include  "ptopo.cdk"
#include  "glb_ld.cdk"
*
      integer MAXVOIS,maxproc
      parameter(MAXVOIS=4,maxproc=2000)
      integer proc(MAXVOIS),nproc,RightProc,LeftProc,TopProc,BottomProc
      integer type,iwk(MAXVOIS*2)
      integer procp1(maxproc),procp2(MAXVOIS),i,j,ierr
*
*     ---------------------------------------------------------------
*
* determine the number and id of the neighboring processors 
*
      RightProc  = Ptopo_myproc+1
      LeftProc   = Ptopo_myproc-1 
      TopProc    = Ptopo_myproc+Ptopo_npex
      BottomProc = Ptopo_myproc-Ptopo_npex
*
      if (G_lam ) then  
         if(l_south) BottomProc =-1
         if(l_north) TopProc    =-1
         if(l_west)  LeftProc   =-1
         if(l_east)  RightProc  =-1
      else
         if (Ptopo_mycol.eq.0) LeftProc=Ptopo_myproc+Ptopo_npex-1
         if (Ptopo_mycol.eq.(Ptopo_npex-1)) RightProc=
     $                                  Ptopo_myproc-Ptopo_npex+1
         if (Ptopo_myrow.eq.0) BottomProc= -1
         if (Ptopo_myrow.eq.(Ptopo_npey-1)) TopProc=-1
      endif
*
      nproc=0
      if(LeftProc.ge.0) then
         nproc=nproc+1
         proc(nproc)=LeftProc
      endif
      if(BottomProc.ge.0) then
         nproc=nproc+1
         proc(nproc)=BottomProc
      endif
      if(RightProc.ge.0) then
         nproc=nproc+1
         proc(nproc)=RightProc
      endif
      if(TopProc.ge.0) then
         nproc=nproc+1
         proc(nproc)= TopProc
      endif
*
      do i=1,nproc
         proc(i)=proc(i)+1
      enddo
*
      do i=1,MAXPROC
         procp1(i)=0
      enddo
*
      do i=1,nproc
         j=proc(i)
         procp1(j)=j
      enddo
*
      nproc=0
      do i=1,Ptopo_numproc
         if(procp1(i).ne.0) then
            nproc=nproc+1
            procp2(nproc)=procp1(i)
         endif
      enddo
* 
      type =12
      call multicd (nproc,procp2,Ptopo_myproc+1,type,mycol,iwk)
*
      call RPN_COMM_allreduce(mycol,ncol,1,"MPI_integer",
     $                             "MPI_max","grid",ierr)
*
*     ---------------------------------------------------------------
*
      return
      end