!-------------------------------------- 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 --------------------------------------
copyright (C) 2001  MSC-RPN COMM  %%%MC2%%%
#include "model_macros_f.h"

      subroutine glbcolc2(f2rc,g_id,g_if,g_jd,g_jf, 4
     $                    f2cc,lminx,lmaxx,lminy,lmaxy,lnk,z_out,nk_out)
      implicit none
*
      integer g_id,g_if,g_jd,g_jf,lminx,lmaxx,lminy,lmaxy,lnk,nk_out
      integer z_out(nk_out)
      real f2rc(g_id:g_if,g_jd:g_jf,nk_out), 
     $     f2cc(lminx:lmaxx,lminy:lmaxy,lnk)
*
#include "glb_ld.cdk"
#include "ptopo.cdk"
*
      integer i, j, k, iproc, tag, err, status
      integer si,sj,loindx,hiindx,loindy,hiindy
      integer len,l_id,l_if,l_jd,l_jf
      common /gatherit/ len,l_id,l_if,l_jd,l_jf
      real buf ((lmaxx-lminx+1)*(lmaxy-lminy+1)*nk_out*2)
      data tag /210/
*
*----------------------------------------------------------------------
*
      loindx=1
      loindy=1
      hiindx=l_ni
      hiindy=l_nj
      if (l_west ) loindx = lminx
      if (l_south) loindy = lminy
      if (l_north) hiindy = lmaxy
      if (l_east ) hiindx = lmaxx
      si = Ptopo_gindx(1,Ptopo_myproc+1) - 1
      sj = Ptopo_gindx(3,Ptopo_myproc+1) - 1
      l_id = max(loindx,(g_id-si))
      l_if = min(hiindx,(g_if-si))
      l_jd = max(loindy,(g_jd-sj))
      l_jf = min(hiindy,(g_jf-sj))
      len = max(0,(l_if-l_id+1))*max(0,(l_jf-l_jd+1))*lnk
*          
      if (Ptopo_myproc.eq.0) then
*
*       Copy local data (LD) segment to global field on processor 1
*
         if (len.gt.0) then
            len = 0
            do k = 1, nk_out
               do j = l_jd, l_jf
               do i = l_id, l_if
                  len = len + 1
                  buf(len) = f2cc(i,j,z_out(k))
               enddo
               enddo
            enddo
            len = 0
            do k = 1, nk_out
               do j = Ptopo_gindx(3,Ptopo_myproc+1)+l_jd-1, 
     $                Ptopo_gindx(3,Ptopo_myproc+1)+l_jf-1
               do i = Ptopo_gindx(1,Ptopo_myproc+1)+l_id-1, 
     $                Ptopo_gindx(1,Ptopo_myproc+1)+l_if-1
                  len = len + 1
                  f2rc(i,j,k) = buf(len)
               enddo
               enddo
            enddo
         endif
*
*       Receive the local data (LD) segments from all other processors
*
         do iproc = 1, Ptopo_numproc-1
            call RPN_COMM_recv ( len, 5, 'MPI_INTEGER', iproc,
     $                           tag,'GRID', status, err )
            if (len.gt.0) then
               call RPN_COMM_recv ( buf, len, 'MPI_REAL', iproc,
     $                           tag,'GRID', status, err )
               len = 0
               do k = 1, nk_out
               do j = Ptopo_gindx(3,iproc+1)+l_jd-1, Ptopo_gindx(3,iproc+1)+l_jf-1
               do i = Ptopo_gindx(1,iproc+1)+l_id-1, Ptopo_gindx(1,iproc+1)+l_if-1
                  len = len + 1
                  f2rc(i,j,k) = buf(len)
               enddo
               enddo
               enddo 
            endif
         enddo 
*
      else
*
*       Send local data (LD) segment to processor 1
*
         len = 0
         do k = 1, nk_out
            do j = l_jd, l_jf
            do i = l_id, l_if
               len = len + 1
               buf(len) = f2cc(i,j,z_out(k))
            enddo
            enddo
         enddo

         call RPN_COMM_send ( len, 5, 'MPI_INTEGER', 0, tag,'GRID',err )
         if (len.gt.0)
     $   call RPN_COMM_send ( buf, len, 'MPI_REAL', 0, tag, 'GRID',err )
*
      endif
*
*----------------------------------------------------------------------
      return
      end
*