MODULE CMP_COMM
use machine , only : kind_REAL, kind_INTEGER
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)
! integer kind_REAL,kind_INTEGER,MPI_kind_REAL,
! >kind_alt_REAL,MPI_kind_alt_REAL
! parameter (kind_REAL=8,kind_INTEGER=4)
integer MPI_kind_REAL, kind_alt_REAL, MPI_kind_alt_REAL
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. (As of 4/21/04, it is not used. It is
! planned to be used in subroutines CMP_alt_SEND and CMP_alt_RECV,
! to be written)
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(2),
>nprocs_global
!cpl mom4
integer, dimension(2) :: ibuf
character*10 s
!
! Determine MPI send/receive types according to prescribed
! types for arrays to be communicated
!
if (kind_REAL == 8) then
MPI_kind_REAL = MPI_REAL8
MPI_kind_alt_REAL = MPI_REAL4
else if (kind_REAL == 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
tag=1
! print*,'CMP_INIT: to call MPI_RECV'
call MPI_RECV(ibuf,size(ibuf),MPI_INTEGER,MPI_ANY_SOURCE,tag,
>MPI_COMM_WORLD,status,ierr)
call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_RECV',1)
Coupler_rank=ibuf(2)
if (ibuf(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
! Inform Coupler that this components exists and is active
!
ibuf(1)=id
ibuf(2)=process_rank_global
call MPI_GATHER(ibuf,2,MPI_INTEGER,dummy,2,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(2),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-1
print*,'CMP_INTRO: to call MPI_SEND ',process_rank_local,
> process_rank_global,'tag=',tag,'coupler=',Coupler_rank,
> 'ibuf=',ibuf(1),ibuf(2)
call MPI_SEND(ibuf,2,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)
c WtF? do i=0,component_nprocs-1
c WtF? if (i.ne.component_master_rank_local) then
c WtF? ibuf(1)=component_master_rank_local
c WtF? ibuf(2)=component_master_rank_global
c WtF? call MPI_SEND(ibuf,2,MPI_INTEGER,i,tag,COMM_local,ierr)
c WtF? end if
c 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-1
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_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-1
! 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)
if (ierr.ne.0) STOP 'CMP_RECV: error in MPI_SEND'
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-1
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_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
C
! -> 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,s//' Coupler_rank=',
>Coupler_rank
! 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!=0, aborting',1)
return
END