#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