source: lmdz_wrf/WRFV3/external/atm_ocn/cmpcomm.F @ 1

#if defined( DM_PARALLEL ) 
      MODULE CMP_COMM

      implicit none

! MPI variables
      include 'mpif.h'
 
      integer Coupler_id /0/   ! this is Coupler's id, used to address
                               ! Coupler. This is a default value,
                               ! possibly to be redefined later
!
!     Make Coupler's id 0 if it is active (i.e. communnicating with
! the Component.) Otherwise, make it a negative integer; in this case,
! the Component is standalone.
!

      integer ibuffer_size
      parameter (ibuffer_size=10)
      integer Coupler_rank,my_id,COMM_local, &
     &component_master_rank_global,process_rank_global, &
     &component_master_rank_local,process_rank_local,&
     &component_nprocs,FlexLev,ibuffer(ibuffer_size),nprocs_global

      integer kind_REAL,kind_INTEGER,MPI_kind_REAL,&
     &kind_alt_REAL,MPI_kind_alt_REAL
      parameter (kind_REAL=8,kind_INTEGER=4)
      parameter (kind_alt_REAL=12-kind_REAL)
!       kind_INTEGER must be number of bytes equal to number of bytes
!     implied by MPI_INTEGER MPI constant; all integers sent/received
!     are of this kind. No value other than 4 is anticipated as of now
!       kind_REAL is type of real data to communicate. The corresponding
!     MPI data type variable MPI_kind_REAL is assigned in CMP_INIT.
!       kind_alt_REAL is alternative type of real data to communicate. 
!     The corresponding MPI data type variable MPI_kind_alt_REAL is
!     assigned in CMP_INIT. (It is used in subroutines CMP_alt_SEND
!     and CMP_alt_RECV,)

      save

      END MODULE CMP_COMM
!
!***********************************************************************
!
      SUBROUTINE CMP_INIT(id,flex)
!                         in  in
!
!     This subroutine must be called by every Component right upon
!     calling MPI_INIT. It assigns a value to the Component communicator
!     COMM_local (which is a global variable in module CMP), to be 
!     thereafter used by the Component in place of
!     MPI_COMM_WORLD wherever it is used by the Component's
!     standalone version. Besides, it stores the Component's id,
!     the process's ranks, and the "flexibility level" (flex) requested
!     by the Component in glob. variables. (The latter parameter affects
!     the mode of communications; for its description, see CMP_SEND and
!     CMP_RECV.) Finally, it starts handshaking with Coupler, receiving
!     the unique (global, i.e. in MPI_COMM_WORLD) Coupler process 
!     rank Coupler_rank from Coupler
                                        ! ibuffer may include additional
                                        ! info to be received
!
      USE CMP_COMM

      implicit none

      integer id,flex

      integer ierr,color,key,status(MPI_STATUS_SIZE),tag,dummy
      character*10 s
      logical izd
!

!        Determine if MPI is initialized, if not initialize
      call MPI_INITIALIZED(izd,ierr)
      if (.not.izd) call MPI_INIT(ierr)

!        Determine MPI send/receive types according to prescribed
!        types for arrays to be communicated
      if (kind_REAL.eq.8) then
        MPI_kind_REAL=MPI_REAL8
        MPI_kind_alt_REAL=MPI_REAL4
      else if (kind_REAL.eq.4) then
        MPI_kind_REAL=MPI_REAL4
        MPI_kind_alt_REAL=MPI_REAL8
      else
        write(s,'(i0)') kind_REAL
        call GLOB_ABORT(1, &
     &  'CMP_INIT: illegal value of kind_REAL='//s,1)
      end if
      if (kind_INTEGER.ne.4) then
        write(s,'(i0)') kind_INTEGER
        call GLOB_ABORT(1, &
     &  'CMP_INIT: illegal value of kind_INTEGER='//s,1)
      end if

!        Store the Component's id
!
      my_id=id

!        Store the Component's "flexibility level"
!
      FlexLev=flex

!        Assign a value to the Component communicator
!        COMM_local, to be thereafter used by the Component in place of
!        MPI_COMM_WORLD wherever it is used by the Component's
!        standalone version
!
      color=id
      key=1
!           print*,'CMP_INIT: to call MPI_COMM_SPLIT, color=',color
      call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,key,COMM_local,ierr)
      call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_COMM_SPLIT',1)

!        Store the process's global and local ranks
!
!           print*,'CMP_INIT: to call MPI_COMM_RANK for global rank'
      call MPI_COMM_RANK(MPI_COMM_WORLD,process_rank_global,ierr)
      call GLOB_ABORT(ierr, &
     &'CMP_INIT: error in MPI_COMM_RANK(MPI_COMM_WORLD...)',1)
!           print*,'CMP_INIT: to call MPI_COMM_RANK for local rank'
      call MPI_COMM_RANK(COMM_local,process_rank_local,ierr)
      call GLOB_ABORT(ierr, &
     &'CMP_INIT: error in MPI_COMM_RANK(COMM_local...)',1)

!        Store component_nprocs - component's number of processes;
!        calculate global number number of processes;
!        determine whether it is standalone mode and if it is, make
!        Coupler's id negative and return
!
      call MPI_COMM_SIZE(COMM_local,component_nprocs,ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs_global,ierr)
      if (component_nprocs.eq.nprocs_global) then
        if(process_rank_local.eq.0) print*,'CMP_INIT: standalone mode'
        Coupler_id=-1
        RETURN
      end if

!        Start handshaking with Coupler (all processes):
!        receive the unique (global, i.e. in MPI_COMM_WORLD) Coupler 
!        process rank Coupler_rank from Coupler
!
      tag=Coupler_id+23456
!           print*,'CMP_INIT: to call MPI_RECV'
      call MPI_RECV(ibuffer,ibuffer_size,MPI_INTEGER,MPI_ANY_SOURCE,tag, &
     &MPI_COMM_WORLD,status,ierr)
      call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_RECV',1)
      Coupler_rank=ibuffer(2)
      if (ibuffer(1).ne.Coupler_id) then
        print*,'CMP_INIT: stopped, rcvd ibuffer(1) value is not C id: ', &
     &  ibuffer(1)
        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
      end if
      if (ibuffer(3).ne.ibuffer_size) then
        print*,'CMP_INIT: stopped, rcvd ibuffer(3) value ',ibuffer(3), &
     &  ' is not ibuffer_size=',ibuffer_size
        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
      end if

!        Inform Coupler that this components exists and is active
!
      call MPI_GATHER(id,1,MPI_INTEGER,dummy,1,MPI_INTEGER, &
     &Coupler_rank,MPI_COMM_WORLD,ierr)

!
!     print*,
!    >'CMP_INIT: ranks: process local, global, Coupler; Coupler_id: ',
!    >process_rank_local,process_rank_global,Coupler_rank,Coupler_id

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_INTRO(master_rank_local)
!                                in
!       This routine must be called by all Component's processes
!       which must all know the local rank of Component's master
!       process (master_rank_local)
!          Alternatively, SUBROUTINE CMP_INTRO_m can be called
!      from Component's master process only, and SUBROUTINE CMP_INTRO_s
!      from all other processes. In this case, the local rank of
!      Component's master process will be determined and broadcast
!      automatically

      USE CMP_COMM

      implicit none
 
      integer master_rank_local,ierr,ibuf(3),color,key,tag
!

!     print*,'CMP_INTRO: entered ',master_rank_local,process_rank_local
!    >,Coupler_rank

      component_master_rank_local=master_rank_local

      if (Coupler_id.lt.0) return    !   <- standalone mode

!        If this process is the Component's master process,
!        complete handshaking with Coupler:
!        "register", i.e. send Component master process global rank 
!        to Coupler. Also, send the requested "flexibility level".
!        (Sending Component's id (in ibuf(1)) is for double-check only.)
!
      if (process_rank_local.eq.master_rank_local) then
        component_master_rank_global=process_rank_global
        ibuf(1)=my_id  ! redundant, sent for control only
        ibuf(2)=process_rank_global
        ibuf(3)=FlexLev
        tag=my_id+54321
            print*,'CMP_INTRO: to call MPI_SEND ',process_rank_local, &
     &      process_rank_global
        call MPI_SEND(ibuf,3,MPI_INTEGER,Coupler_rank,tag, &
     &  MPI_COMM_WORLD,ierr)
        if (ierr.ne.0) then
          print*,'CMP_INTRO: error in MPI_SEND, process ', &
     &    process_rank_global
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        end if
      end if
!           print*,'CMP_INTRO: returning ',process_rank_local,
!    >      process_rank_global,Coupler_rank
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_INTRO_m
!
!      This routine must be called by Component's master process (only),
!      if CMP_INTRO is not called (see comments in CMP_INTRO)

      USE CMP_COMM

      implicit none
 
      integer ierr,ibuf(3),color,key,tag,i
!

!     print*,'CMP_INTRO_m: entered, process_rank_local=',
!    >process_rank_local

      component_master_rank_local=process_rank_local
      component_master_rank_global=process_rank_global

      tag=abs(my_id)+12345
      do i=0,component_nprocs-1
        if (i.ne.component_master_rank_local) then
          ibuf(1)=component_master_rank_local
          ibuf(2)=component_master_rank_global
          call MPI_SEND(ibuf,2,MPI_INTEGER,i,tag,COMM_local,ierr)
          if (ierr.ne.0) then
            print*,'CMP_INTRO_m: error in 1st MPI_SEND, i=',i
            CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
          end if
        end if
      end do

      if (Coupler_id.lt.0) return    !   <- standalone mode

!        Complete handshaking with Coupler:
!        "register", i.e. send Component master process global rank 
!        to Coupler. Also, send the requested "flexibility level".
!        (Sending Component's id (in ibuf(1)) is for double-check only.)
!
      tag=my_id+54321
      ibuf(1)=my_id  ! redundant, sent for control only
      ibuf(2)=process_rank_global
      ibuf(3)=FlexLev
!         print*,'CMP_INTRO_m: to call MPI_SEND ',process_rank_local,
!    >    process_rank_global
      call MPI_SEND(ibuf,3,MPI_INTEGER,Coupler_rank,tag, &
     &MPI_COMM_WORLD,ierr)
      if (ierr.ne.0) then
        print*,'CMP_INTRO_m: error in MPI_SEND, process ', &
     &  process_rank_global
        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
      end if
!         print*,'CMP_INTRO_m: returning ',process_rank_local,
!    >    process_rank_global
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_INTRO_s
!
!      This routine must be called by all Component's processes other
!      than master process,
!      if CMP_INTRO is not called (see comments in CMP_INTRO)

      USE CMP_COMM

      implicit none
 
      integer ierr,ibuf(3),color,key,tag,i,status(MPI_STATUS_SIZE)
!

!     print*,'CMP_INTRO_s: entered, process_rank_local=',
!    >process_rank_local

      tag=abs(my_id)+12345
      call MPI_RECV(ibuf,2,MPI_INTEGER,MPI_ANY_SOURCE,tag, &
     &COMM_local,status,ierr)
      if (ierr.ne.0) then
        print*,'CMP_INTRO_s: error in MPI_RECV ',process_rank_local
        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
      end if
      component_master_rank_local=ibuf(1)
      component_master_rank_global=ibuf(2)
! WtF?      do i=0,component_nprocs-1
! WtF?        if (i.ne.component_master_rank_local) then
! WtF?          ibuf(1)=component_master_rank_local
! WtF?          ibuf(2)=component_master_rank_global
! WtF?          call MPI_SEND(ibuf,2,MPI_INTEGER,i,tag,COMM_local,ierr)
! WtF?        end if
! WtF?      end do

!         print*,'CMP_INTRO_s: returning ',process_rank_local,
!    >    process_rank_global,component_master_rank_local,
!    >    component_master_rank_global
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_SEND(F,N)
!
      USE CMP_COMM

      implicit none
 
      integer N,ierr,tag
      real(kind=kind_REAL) F(N)
!
      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_SEND: entered')

      if (process_rank_local.ne.component_master_rank_local) then
        if (FlexLev.eq.0) then
!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.
          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        else if (FlexLev.eq.1) then
!         With "flexibility level" FlexLev=1, any Component process is 
!         allowed to call this subroutine but only the Component
!         master process can actually send data (so the
!         others just make a dummy call), as the Coupler process only 
!         receives data from the Component master process.
          return
        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        end if
!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
!         Component process is allowed to actually send data.
!         [In this case, the Coupler process (in CPL_RECV) receives 
!         from MPI_ANY_SOURCE rather than component_master_rank_global,
!         and it is only identification by  tag  which enables Coupler
!         to receive the data from the right source.]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.
      end if

      tag=my_id

      call MPI_SEND(F,N,MPI_kind_REAL,Coupler_rank,tag, &
     &MPI_COMM_WORLD,ierr)
      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)

!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_alt_SEND(F,N)
!
      USE CMP_COMM

      implicit none
 
      integer N,ierr,tag
      real(kind=kind_alt_REAL) F(N)
!
      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_alt_SEND: entered')

      if (process_rank_local.ne.component_master_rank_local) then
        if (FlexLev.eq.0) then
!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.
          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        else if (FlexLev.eq.1) then
!         With "flexibility level" FlexLev=1, any Component process is 
!         allowed to call this subroutine but only the Component
!         master process can actually send data (so the
!         others just make a dummy call), as the Coupler process only 
!         receives data from the Component master process.
          return
        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        end if
!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
!         Component process is allowed to actually send data.
!         [In this case, the Coupler process (in CPL_RECV) receives 
!         from MPI_ANY_SOURCE rather than component_master_rank_global,
!         and it is only identification by  tag  which enables Coupler
!         to receive the data from the right source.]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.
      end if

      tag=my_id

      call MPI_SEND(F,N,MPI_kind_alt_REAL,Coupler_rank,tag, &
     &MPI_COMM_WORLD,ierr)
      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)

!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_gnr_SEND(F,N,MPI_DATATYPE)
!
      USE CMP_COMM

      implicit none
 
      integer N,MPI_DATATYPE
      integer F(1)

      integer ierr,tag
!

      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_alt_SEND: entered')

      if (process_rank_local.ne.component_master_rank_local) then
        if (FlexLev.eq.0) then
!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.
          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        else if (FlexLev.eq.1) then
!         With "flexibility level" FlexLev=1, any Component process is 
!         allowed to call this subroutine but only the Component
!         master process can actually send data (so the
!         others just make a dummy call), as the Coupler process only 
!         receives data from the Component master process.
          return
        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        end if
!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
!         Component process is allowed to actually send data.
!         [In this case, the Coupler process (in CPL_RECV) receives 
!         from MPI_ANY_SOURCE rather than component_master_rank_global,
!         and it is only identification by  tag  which enables Coupler
!         to receive the data from the right source.]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.
      end if

      tag=my_id

      call MPI_SEND(F,N,MPI_DATATYPE,Coupler_rank,tag, &
     &MPI_COMM_WORLD,ierr)
      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)

!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_INTEGER_SEND(F,N)
!
      USE CMP_COMM

      implicit none
 
      integer N,ierr,tag
      integer F(N)
!
      if (Coupler_id.lt.0) return    !   <- standalone mode

!           print*,'CMP_INTEGER_SEND: entered with N=',N,' F=',F,
!    >      '; my_id=',my_id,'Coupler_rank=',Coupler_rank

      if (process_rank_local.ne.component_master_rank_local) then
        if (FlexLev.eq.0) then
!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.
          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        else if (FlexLev.eq.1) then
!         With "flexibility level" FlexLev=1, any Component process is 
!         allowed to call this subroutine but only the Component
!         master process can actually send data (so the
!         others just make a dummy call), as the Coupler process only 
!         receives data from the Component master process.
          return
        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
        end if
!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
!         Component process is allowed to actually send data.
!         [In this case, the Coupler process (in CPL_RECV) receives 
!         from MPI_ANY_SOURCE rather than component_master_rank_global,
!         and it is only identification by  tag  which enables Coupler
!         to receive the data from the right source.]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.
      end if

      tag=my_id
            print*,'CMP_INTEGER_SEND: to call MPI_SEND; F=', &
     &      F,' N=',N,' Coupler_rank=',Coupler_rank,' tag=',tag
      call MPI_SEND(F,N,MPI_INTEGER,Coupler_rank,tag, &
     &MPI_COMM_WORLD,ierr)
      call GLOB_ABORT(ierr,'CMP_INTEGER_SEND: error in MPI_SEND',1)
            print*,'CMP_INTEGER_SEND: to return'

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_RECV(F,N)
!
      USE CMP_COMM

      implicit none
 
      integer N,ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
      real(kind=kind_REAL) F(N)
!
      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_RECV: entered')

      if (process_rank_local.ne.component_master_rank_local) then

        if (FlexLev.eq.0) then

!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.

          print '("*** CMP_RECV: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then

!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
!         Component process is allowed to call this subroutine but 
!         only the Component master process is supposed to actually 
!         receive data (so the others just make a dummy call), as
!         the Coupler process only sends data to the Component master
!         process.

          return

        else if (FlexLev.eq.3) then

!         With "flexibility level" FlexLev=3, any Component process
!         may actually receive data.
!         [In this case, the Coupler process (in CPL_SEND) first
!         receives the Component process global rank 
!         (process_rank_global) from this subroutine, the source being
!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
!         enables Coupler to receive process_rank_global from the right
!         source. Upon the receipt, the Coupler process (in CPL_SEND)
!         sends the data to this Component process, rather than to 
!         the Component master process as is the case with lower 
!         "flexibility levels".]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.

          ibuf(1)=my_id
          ibuf(2)=process_rank_global
          tag=my_id
          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
     &    MPI_COMM_WORLD,ierr)
          call GLOB_ABORT(ierr,'CMP_RECV: error in MPI_SEND',1)

        else

          print '("*** CMP_RECV: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        end if

      end if

      tag=my_id
      call MPI_RECV(F,N,MPI_kind_REAL,Coupler_rank,tag, &
     &MPI_COMM_WORLD,status,ierr)
      call GLOB_ABORT(ierr,'CMP_RECV: error in MPI_RECV',1)

!           call CMP_DBG_CR(6,'CMP_RECV: exiting')

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_alt_RECV(F,N)
!
      USE CMP_COMM

      implicit none
 
      integer N,ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
      real(kind=kind_alt_REAL) F(N)
!
      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_alt_RECV: entered')

      if (process_rank_local.ne.component_master_rank_local) then

        if (FlexLev.eq.0) then

!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.

          print '("*** CMP_alt_RECV: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then

!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
!         Component process is allowed to call this subroutine but 
!         only the Component master process is supposed to actually 
!         receive data (so the others just make a dummy call), as
!         the Coupler process only sends data to the Component master
!         process.

          return

        else if (FlexLev.eq.3) then

!         With "flexibility level" FlexLev=3, any Component process
!         may actually receive data.
!         [In this case, the Coupler process (in CPL_SEND) first
!         receives the Component process global rank 
!         (process_rank_global) from this subroutine, the source being
!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
!         enables Coupler to receive process_rank_global from the right
!         source. Upon the receipt, the Coupler process (in CPL_SEND)
!         sends the data to this Component process, rather than to 
!         the Component master process as is the case with lower 
!         "flexibility levels".]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.

          ibuf(1)=my_id
          ibuf(2)=process_rank_global
          tag=my_id
          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
     &    MPI_COMM_WORLD,ierr)
          call GLOB_ABORT(ierr,'CMP_alt_RECV: error in MPI_SEND',1)

        else

          print '("*** CMP_alt_RECV: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        end if

      end if

      tag=my_id
      call MPI_RECV(F,N,MPI_kind_alt_REAL,Coupler_rank,tag, &
     &MPI_COMM_WORLD,status,ierr)
      call GLOB_ABORT(ierr,'CMP_alt_RECV: error in MPI_RECV',1)

!           call CMP_DBG_CR(6,'CMP_alt_RECV: exiting')

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_gnr_RECV(F,N,MPI_DATATYPE)
!
      USE CMP_COMM

      implicit none
 
      integer N,MPI_DATATYPE
      integer F(1)

      integer ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
!

      if (Coupler_id.lt.0) return    !   <- standalone mode

!           call CMP_DBG_CR(6,'CMP_gnr_RECV: entered')

      if (process_rank_local.ne.component_master_rank_local) then

        if (FlexLev.eq.0) then

!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.

          print '("*** CMP_gnr_RECV: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then

!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
!         Component process is allowed to call this subroutine but 
!         only the Component master process is supposed to actually 
!         receive data (so the others just make a dummy call), as
!         the Coupler process only sends data to the Component master
!         process.

          return

        else if (FlexLev.eq.3) then

!         With "flexibility level" FlexLev=3, any Component process
!         may actually receive data.
!         [In this case, the Coupler process (in CPL_SEND) first
!         receives the Component process global rank 
!         (process_rank_global) from this subroutine, the source being
!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
!         enables Coupler to receive process_rank_global from the right
!         source. Upon the receipt, the Coupler process (in CPL_SEND)
!         sends the data to this Component process, rather than to 
!         the Component master process as is the case with lower 
!         "flexibility levels".]
!         But in any case only one Component process may actually be
!         engaged in a particular exchange of data with Coupler.

          ibuf(1)=my_id
          ibuf(2)=process_rank_global
          tag=my_id
          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
     &    MPI_COMM_WORLD,ierr)
          call GLOB_ABORT(ierr,'CMP_gnr_RECV: error in MPI_SEND',1)

        else

          print '("*** CMP_gnr_RECV: illegal value of FlexLev",i9/ &
     &    "*** STOPPED")',FlexLev
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

        end if

      end if

      tag=my_id
      call MPI_RECV(F,N,MPI_DATATYPE,Coupler_rank,tag, &
     &MPI_COMM_WORLD,status,ierr)
      call GLOB_ABORT(ierr,'CMP_gnr_RECV: error in MPI_RECV',1)

!           call CMP_DBG_CR(6,'CMP_gnr_RECV: exiting')

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_ANNOUNCE(nunit,s)
!
      USE CMP_COMM

      implicit none

      character*(*) s
 
      integer nunit,ierr
!

      if (process_rank_local.eq.component_master_rank_local) then
        write(nunit,*) trim(s)
      else if (FlexLev.eq.0) then

!         With "flexibility level" FlexLev=0, only Component master 
!         process is supposed to call this subroutine.

          print '("*** CMP_ANNOUNCE: process_rank_local=",i4,"  ***"/ &
     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
     &    "*** STOPPED ***")', &
     &    process_rank_local,component_master_rank_local
          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)

      end if

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_STDOUT(s)
!
!     USE CMP_COMM, ONLY: Coupler_id,process_rank_global
        ! <- These values may not have the right value by this moment,
        ! as this routine may be called before CMP_INIT  - 02/23/05

      implicit none

      character*(*) s
      integer ios
      character*4 mess
!

! -> For debugging:
      OPEN(12345, &
     &file='/nfsuser/g01/wx20ds/C/cmp.stdout', &
     &form='formatted',status='old',iostat=ios)
      if (ios.eq.0) then
        read(12345,*) mess
        if (mess.eq.'mess') then
!         print*,'CMP_STDOUT: unit 6 left alone, process ',
!    >    process_rank_global
        ! <- process_rank_global may be undefined by this moment, as
        !    this routine may be called before CMP_INIT  - 02/23/05
          RETURN
        end if
        CLOSE(12345)
      end if
! <- for debugging

!     if (Coupler_id.lt.0) RETURN    ! Nothing is to occur if there is
                                     ! no communication with Coupler,
                                     ! i.e. if Component is standalone
        ! <- Coupler_id may not have the right value by this moment,
        ! as this routine may be called before CMP_INIT  - 02/23/05

      if (len_trim(s).eq.0) RETURN

      close(6)
      
      open(6,file=trim(s),form='formatted',status='unknown')

      print*,'CMP_STDOUT: unit 6 closed, reopened as '//trim(s)

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_DBG_CR(nunit,s)
!
!       Debugging routine: mainly, prints Coupler_rank
!
      USE CMP_COMM

      implicit none

      character*(*) s
      integer nunit

      integer ncall/0/,ncallmax/5000/
      save
!

      if (s(5:6).eq.'m:') then
        if (process_rank_local .ne. component_master_rank_local) RETURN
      end if

      if (ncall.ge.ncallmax) RETURN
      ncall=ncall+1

      write(nunit,*)process_rank_global,ncall,Coupler_id,Coupler_rank,s

! The following assumes that Coupler_rank must be =0, comment out if
! this is not the case
      call GLOB_ABORT(Coupler_rank, &
     &'CMP_DBG_CR: Coupler_rank.ne.0, aborting',1)

      return
      END
!
!***********************************************************************
!
      SUBROUTINE CMP_FLUSH(nunit)

      USE CMP_COMM

      implicit none

      integer nunit

      integer i,ierr,rc
!

      do i=0,component_nprocs-1
        call MPI_BARRIER(COMM_local,ierr)
        call GLOB_ABORT(ierr,'CMP_FLUSH: MPI_BARRIER failed, aborting', &
     &  rc)
        if (i.eq.process_rank_local) call FLUSH(nunit)
      end do

      return
      END
!
!***********************************************************************
!
      subroutine CMP_FINALIZE(izd,ierr)

      USE CMP_COMM

      implicit none

      logical izd
      integer ierr

      integer ierr1,ierr2
!

      ierr=0
      ierr2=0
      call MPI_INITIALIZED(izd,ierr1)
      if (izd) call MPI_FINALIZE(ierr2)
      ierr=abs(ierr1)+abs(ierr2)

      return
      END
#endif