mo_mpi.f90
MODULE mo_mpi
! Comment: Please use basic WRITE to nerr for messaging in the whole
! MPI package to achieve proper output.
5:
USE mo_kind
USE mo_doctor, ONLY: nerr
IMPLICIT NONE
10:
PRIVATE ! all declarations are private
! subroutines defined, overloaded depending on argument type
15: PUBLIC :: p_start, p_stop, p_abort
PUBLIC :: p_send, p_recv, p_bcast, p_barrier
PUBLIC :: p_isend, p_wait
PUBLIC :: p_max, p_min
PUBLIC :: p_set_communicator
20: PUBLIC :: p_probe
! logical switches
PUBLIC :: p_parallel, p_parallel_io
25:
! PE identifier
PUBLIC :: p_pe, p_io, p_nprocs
30: ! communicator
PUBLIC :: p_communicator_a, p_communicator_b, p_communicator_d
! request values for non blocking calls
35:
PUBLIC :: p_request, p_irequest
! old fashioned method (MPI-1)
40: #ifndef NOMPI
INCLUDE 'mpif.h'
#endif
! Fujitsu VPP 700 MPI has not defined the optional MPI_INTEGER4 and
45: ! MPI_INTEGER8. Both are redefined to MPI_INTEGER.
#ifdef __uxp__
#define MPI_INTEGER4 MPI_INTEGER
#define MPI_INTEGER8 MPI_INTEGER
50: #endif
! IBM RS/6000 SP MPI has not defined the optional MPI_INTEGER8. It is
! redefined to MPI_INTEGER.
55: ! #ifdef _AIX
#ifdef AIX
#define MPI_INTEGER8 MPI_INTEGER
#endif
60: ! general run time information
#if ! (defined (SX) || defined (__uxp__))
INTEGER :: version, subversion ! MPI version
#endif
65:
! MPI call inherent variables
INTEGER :: p_error ! MPI error number
70: #ifndef NOMPI
INTEGER :: p_status(MPI_STATUS_SIZE) ! standard information of MPI_RECV
#else
INTEGER :: p_status(1)
#endif
75:
! public parallel run information
LOGICAL :: p_parallel, p_parallel_io
80: INTEGER :: p_pe ! this is the PE number of this task
INTEGER :: p_io ! PE number of PE handling IO
INTEGER :: p_nprocs ! number of available PEs (processors)
! communicator sets
85:
INTEGER :: p_communicator_a ! for Set A
INTEGER :: p_communicator_b ! for Set B
INTEGER :: p_communicator_d ! for debug node
90: ! non blocking calls
INTEGER, ALLOCATABLE :: p_request(:)
INTEGER :: p_irequest ! the first p_irequest-1 values of p_request are in use
95: ! module intrinsic names
INTEGER :: mype ! this is the PE number of this task
INTEGER :: iope ! PE able to do IO
INTEGER :: npes ! number of available PEs
100:
INTEGER :: nbcast ! counter for broadcasts for debugging
! MPI transfer types
105: INTEGER :: p_real_sp
INTEGER :: p_real_dp
INTEGER :: p_int_i4
INTEGER :: p_int_i8
INTEGER :: p_int_cp
110:
! native types
INTEGER :: p_int ! maybe switched by compiler options therefor reset
INTEGER :: p_real ! maybe switched by compiler options therefor reset
115:
INTEGER :: p_bool
INTEGER :: p_char
INTEGER :: p_ig, p_rg
120: INTEGER :: p_i4, p_i8
INTEGER :: p_sp, p_dp
! for checking out integer and real variables separat. KIND values usually
! overlap and give the byte size or are defined as sequence separate for
125: ! both groups.
INTEGER, PARAMETER :: real_type = 1
INTEGER, PARAMETER :: integer_type = 2
130: ! define generic interfaces to allow proper compiling
! with picky compilers like NAG f95 for clean argument checking and
! shortening the call sequence.
INTERFACE p_send
135: MODULE PROCEDURE p_send_real
MODULE PROCEDURE p_send_int
MODULE PROCEDURE p_send_bool
MODULE PROCEDURE p_send_real_1d
MODULE PROCEDURE p_send_int_1d
140: MODULE PROCEDURE p_send_bool_1d
MODULE PROCEDURE p_send_real_2d
MODULE PROCEDURE p_send_int_2d
MODULE PROCEDURE p_send_bool_2d
MODULE PROCEDURE p_send_real_3d
145: MODULE PROCEDURE p_send_int_3d
MODULE PROCEDURE p_send_bool_3d
MODULE PROCEDURE p_send_real_4d
MODULE PROCEDURE p_send_int_4d
MODULE PROCEDURE p_send_bool_4d
150: MODULE PROCEDURE p_send_char
MODULE PROCEDURE p_send_real_5d
END INTERFACE
INTERFACE p_isend
155: MODULE PROCEDURE p_isend_real
MODULE PROCEDURE p_isend_int
MODULE PROCEDURE p_isend_bool
MODULE PROCEDURE p_isend_real_1d
MODULE PROCEDURE p_isend_int_1d
160: MODULE PROCEDURE p_isend_bool_1d
MODULE PROCEDURE p_isend_real_2d
MODULE PROCEDURE p_isend_int_2d
MODULE PROCEDURE p_isend_bool_2d
MODULE PROCEDURE p_isend_real_3d
165: MODULE PROCEDURE p_isend_int_3d
MODULE PROCEDURE p_isend_bool_3d
MODULE PROCEDURE p_isend_real_4d
MODULE PROCEDURE p_isend_int_4d
MODULE PROCEDURE p_isend_bool_4d
170: MODULE PROCEDURE p_isend_char
MODULE PROCEDURE p_isend_real_5d
END INTERFACE
INTERFACE p_recv
175: MODULE PROCEDURE p_recv_real
MODULE PROCEDURE p_recv_int
MODULE PROCEDURE p_recv_bool
MODULE PROCEDURE p_recv_real_1d
MODULE PROCEDURE p_recv_int_1d
180: MODULE PROCEDURE p_recv_bool_1d
MODULE PROCEDURE p_recv_real_2d
MODULE PROCEDURE p_recv_int_2d
MODULE PROCEDURE p_recv_bool_2d
MODULE PROCEDURE p_recv_real_3d
185: MODULE PROCEDURE p_recv_int_3d
MODULE PROCEDURE p_recv_bool_3d
MODULE PROCEDURE p_recv_real_4d
MODULE PROCEDURE p_recv_int_4d
MODULE PROCEDURE p_recv_bool_4d
190: MODULE PROCEDURE p_recv_char
MODULE PROCEDURE p_recv_real_5d
END INTERFACE
INTERFACE p_bcast
195: MODULE PROCEDURE p_bcast_real
MODULE PROCEDURE p_bcast_int_i4
MODULE PROCEDURE p_bcast_int_i8
MODULE PROCEDURE p_bcast_bool
MODULE PROCEDURE p_bcast_real_1d
200: MODULE PROCEDURE p_bcast_int_1d
MODULE PROCEDURE p_bcast_bool_1d
MODULE PROCEDURE p_bcast_real_2d
MODULE PROCEDURE p_bcast_int_2d
MODULE PROCEDURE p_bcast_bool_2d
205: MODULE PROCEDURE p_bcast_real_3d
MODULE PROCEDURE p_bcast_int_3d
MODULE PROCEDURE p_bcast_bool_3d
MODULE PROCEDURE p_bcast_real_4d
MODULE PROCEDURE p_bcast_int_4d
210: MODULE PROCEDURE p_bcast_bool_4d
MODULE PROCEDURE p_bcast_char
END INTERFACE
INTERFACE p_probe
215: MODULE PROCEDURE p_probe_real
MODULE PROCEDURE p_probe_int
MODULE PROCEDURE p_probe_bool
MODULE PROCEDURE p_probe_char
END INTERFACE
220:
INTERFACE p_max
MODULE PROCEDURE p_max_0d
MODULE PROCEDURE p_max_1d
MODULE PROCEDURE p_max_2d
225: MODULE PROCEDURE p_max_3d
END INTERFACE
INTERFACE p_min
MODULE PROCEDURE p_min_0d
230: MODULE PROCEDURE p_min_1d
MODULE PROCEDURE p_min_2d
MODULE PROCEDURE p_min_3d
END INTERFACE
235: CONTAINS
SUBROUTINE p_start
! variables are required for determing I/O size in bytes of the defined
240: ! KIND types for assigning the right MPI data types with the used kinds
INTEGER :: io_size, integer_io_size, integer_byte_size
INTEGER :: iig = 0
245: INTEGER (i4) :: ii4 = 0_i4
INTEGER (i8) :: ii8 = 0_i8
REAL :: rrg = 0.0
REAL (sp) :: rsp = 0.0_sp
250: REAL (dp) :: rdp = 0.0_dp
! temporary array to distibute the determined MPI types
INTEGER :: p_send(7)
255:
! variables used for determing the I/O PE
LOGICAL :: liope
INTEGER, ALLOCATABLE :: iope_table(:)
260: CHARACTER (132) :: io_pe_message
! Executable statements:
nbcast = 0
265:
io_pe_message(:) = ' '
! start MPI
270: #ifndef NOMPI
CALL MPI_INIT (p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_INIT failed.'
275: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
280: ! get local PE identification
#ifndef NOMPI
CALL MPI_COMM_RANK (MPI_COMM_WORLD, mype, p_error)
285: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_COMM_RANK failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
290: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a)') ' Error = ', p_error
STOP
END IF
295: ELSE
#ifdef DEBUG
WRITE (nerr,'(a,i4,a)') ' PE ', mype, ' started.'
#endif
END IF
300: #else
mype = 0
#endif
! get number of available PEs
305:
#ifndef NOMPI
CALL MPI_COMM_SIZE (MPI_COMM_WORLD, npes, p_error)
IF (p_error /= MPI_SUCCESS) THEN
310: WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_SIZE failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
315: WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
320: #else
npes = 1
#endif
! for non blocking calls
325:
ALLOCATE (p_request(100*npes))
p_irequest = 1
! look for a dedicated IO PE
330:
#ifndef NOMPI
CALL MPI_ATTR_GET (MPI_COMM_WORLD, MPI_IO, iope, liope, p_error)
IF (p_error /= MPI_SUCCESS) THEN
335: WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_ATTR_GET failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
340: WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
345:
IF (iope == MPI_ANY_SOURCE) THEN
! all nodes can do IO
350: IF (mype == 0) THEN
WRITE (io_pe_message,'(a)') &
' All nodes can do I/O, selecet PE 0 for I/O handling.'
END IF
p_io = 0
355:
ELSE
ALLOCATE (iope_table(npes))
360: IF (liope) THEN
iope_table(mype) = iope
CALL MPI_GATHER (iope_table(mype), 1, MPI_INTEGER, &
iope_table, 1, MPI_INTEGER, &
0, MPI_COMM_WORLD, p_error)
365:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_GATHER failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
370:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
375: END IF
END IF
IF (mype == 0) THEN
! Now select the first given iope from table as IO PE.
380: WRITE (io_pe_message,'(a,i3,a)') &
' Selecet PE ', iope_table(1), ' for I/O handling.'
p_io = iope_table(1)
END IF
CALL MPI_BCAST (p_io, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, p_error)
385:
ELSE
! if no dedicated IO PE is given, use PE 0
p_io = 0
390: WRITE (io_pe_message,'(a)') &
' No dedicated I/O PE, selecet PE 0 for I/O handling.'
END IF
DEALLOCATE (iope_table)
395:
END IF
#else
p_io = 0
#endif
400:
! Information ...
IF (mype == 0) THEN
WRITE (nerr,'(/,a)') ' ECHAM MPI interface runtime information:'
405: END IF
IF (npes < 2) THEN
p_parallel = .FALSE.
p_parallel_io = .TRUE. ! can always do I/O
410: IF (mype == 0) THEN
WRITE (nerr,'(/)')
WRITE (nerr,'(a)') ' Single processor run.'
END IF
p_pe = 0
415: p_nprocs = 1
ELSE
p_parallel = .TRUE.
IF (mype == p_io) THEN
p_parallel_io = .TRUE.
420: ELSE
p_parallel_io = .FALSE.
END IF
IF (mype == 0) THEN
WRITE (nerr,'(/)')
425: WRITE (nerr,'(a,i4,a)') ' Run on ', npes, ' processors.'
END IF
p_pe = mype
p_nprocs = npes
END IF
430:
! inform on I/O PE situation
IF (mype == 0) THEN
WRITE (nerr, '(a)') io_pe_message(1:LEN_TRIM(io_pe_message))
435: END IF
#ifndef NOMPI
IF (p_parallel) THEN
440:
#if ! (defined (SX) || defined (__uxp__))
! lets check the available MPI version
445: CALL MPI_GET_VERSION (version, subversion, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_GET_VERSION failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
450: CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
455: STOP
END IF
END IF
IF (mype == 0) THEN
460: WRITE (nerr,'(a,i1,a1,i1)') &
' Used MPI version: ', version, '.', subversion
END IF
#endif
465: ! due to a possible circular dependency with mo_machine and other
! modules, we determine here locally the I/O size of the different
! kind types (assume 8 bit/byte. This is than used for determing
! the right MPI send/receive type parameters.
470: ! first get the native INTEGER size
integer_byte_size = BIT_SIZE(iig)/8
! and inquire for the I/O size (is independent of byte or word
475: ! values ...)
INQUIRE (iolength=io_size) iig
integer_io_size = io_size
p_ig = io_size/integer_io_size*integer_byte_size
480:
! and the native REAL size
INQUIRE (iolength=io_size) rrg
p_rg = io_size/integer_io_size*integer_byte_size
485:
! find now the size of usual 4 byte and 8 byte INTEGER
! (might be 8 byte both, or only the 4 byte available ...
INQUIRE (iolength=io_size) ii4
490: p_i4 = io_size/integer_io_size*integer_byte_size
INQUIRE (iolength=io_size) ii8
p_i8 = io_size/integer_io_size*integer_byte_size
! find now the size of usual 4 byte and 8 byte REAL
495: ! (might be 8 byte both)
INQUIRE (iolength=io_size) rsp
p_sp = io_size/integer_io_size*integer_byte_size
INQUIRE (iolength=io_size) rdp
500: p_dp = io_size/integer_io_size*integer_byte_size
! testing this variables
p_int_i4 = p_type (i4, integer_type)
505: p_int_i8 = p_type (i8, integer_type)
p_real_sp = p_type (sp, real_type)
p_real_dp = p_type (dp, real_type)
IF (mype == 0) THEN
510:
IF (p_ig == p_i4) THEN
p_int = p_int_i4
ELSE IF (p_ig == p_i8) THEN
p_int = p_int_i8
515: END IF
IF (p_rg == p_sp) THEN
p_real = p_real_sp
ELSE IF (p_rg == p_dp) THEN
520: p_real = p_real_dp
END IF
IF (i4 == cp) THEN
p_int_cp = p_int_i4
525: ELSE IF (i8 == cp) THEN
p_int_cp = p_int_i8
END IF
END IF
530:
p_send(1) = p_int
p_send(2) = p_int_i4
p_send(3) = p_int_i8
p_send(4) = p_int_cp
535: p_send(5) = p_real
p_send(6) = p_real_sp
p_send(7) = p_real_dp
CALL MPI_BCAST (p_send, 7, MPI_INTEGER, 0, MPI_COMM_WORLD, p_error)
540:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_BCAST for send/receive types failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
545: END IF
#endif
p_int = p_send(1)
p_int_i4 = p_send(2)
550: p_int_i8 = p_send(3)
p_int_cp = p_send(4)
p_real = p_send(5)
p_real_sp = p_send(6)
p_real_dp = p_send(7)
555:
! set logical and character types to native types
p_bool = MPI_LOGICAL
p_char = MPI_CHARACTER
560:
IF (mype == 0) THEN
WRITE (nerr,'(/)')
IF (p_real_sp == MPI_REAL) THEN
WRITE (nerr,'(a)') ' Selected type: MPI_REAL for KIND sp'
565: ELSE IF (p_real_sp == MPI_DOUBLE_PRECISION) THEN
WRITE (nerr,'(a)') &
' Selected type: MPI_DOUBLE_PRECISION for KIND sp'
END IF
570: IF (p_real_dp == MPI_DOUBLE_PRECISION) THEN
WRITE (nerr,'(a)') &
' Selected type: MPI_DOUBLE_PRECISION for KIND dp'
END IF
575: IF (p_int_i4 == MPI_INTEGER4) THEN
WRITE (nerr,'(a)') ' Selected type: MPI_INTEGER4 for KIND i4'
ELSE IF (p_int_i4 == MPI_INTEGER8) THEN
WRITE (nerr,'(a)') ' Selected type: MPI_INTEGER8 for KIND i4'
END IF
580:
IF (p_int_i8 == MPI_INTEGER8) THEN
WRITE (nerr,'(a)') ' Selected type: MPI_INTEGER8 for KIND i8'
END IF
END IF
585: END IF
#endif
WRITE (nerr,'(/)')
590: #ifdef DEBUG
WRITE (nerr,'(a)') ' Transfer types:'
WRITE (nerr,'(a,i4)') ' INTEGER generic:', p_int
WRITE (nerr,'(a,i4)') ' INTEGER 4 byte :', p_int_i4
WRITE (nerr,'(a,i4)') ' INTEGER 8 byte :', p_int_i8
595: WRITE (nerr,'(a,i4)') ' pointer :', p_int_cp
WRITE (nerr,'(a,i4)') ' REAL generic :', p_real
WRITE (nerr,'(a,i4)') ' REAL single :', p_real_sp
WRITE (nerr,'(a,i4)') ' REAL double :', p_real_dp
#endif
600:
END SUBROUTINE p_start
SUBROUTINE p_stop
605: ! finish MPI and clean up all PEs
#ifndef NOMPI
CALL p_barrier ! to prevent abort due to unfinished communication
610: CALL MPI_FINALIZE (p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_FINALIZE failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
615:
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
620: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
625: #endif
END SUBROUTINE p_stop
SUBROUTINE p_abort
630:
! this routine should be used instead of abort, util_abort() or STOP
! in all routines for proper clean up of all PEs
#ifndef NOMPI
635: CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
640: STOP
END IF
#endif
END SUBROUTINE p_abort
645:
FUNCTION p_type (kind_type, var_type) RESULT (p_message_type)
USE mo_kind
650: INTEGER :: p_message_type
INTEGER, INTENT(in) :: kind_type, var_type
IF (var_type == integer_type) THEN
IF (kind_type == i8) THEN
655: p_message_type = check_type_i8 ()
ELSE IF (kind_type == i4) THEN
p_message_type = check_type_i4 ()
END IF
ELSE IF (var_type == real_type) THEN
660: IF (kind_type == dp) THEN
p_message_type = check_type_dp ()
ELSE IF (kind_type == sp) THEN
p_message_type = check_type_sp ()
END IF
665: END IF
END FUNCTION p_type
FUNCTION check_type_i4 () RESULT (p_type)
670:
INTEGER :: p_type
#ifndef NOMPI
INTEGER :: datatype
675:
INTEGER (i4) :: buf_int_i4(1,8)
INTEGER (i4) :: a, b, c
p_type = MPI_DATATYPE_NULL
680:
IF (mype == 0) THEN
a = HUGE(a)
buf_int_i4(1,1) = a
685:
CALL MPI_SEND (buf_int_i4(1,1), 1, MPI_INTEGER4, 1, 1, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i4(1,5), 1, MPI_INTEGER4, 1, 2, &
MPI_COMM_WORLD, p_status, p_error)
690: b = buf_int_i4(1,5)
IF (a == b) THEN
CALL MPI_SEND (MPI_BYTE, 1, MPI_INTEGER, 1, 0, &
MPI_COMM_WORLD, p_error)
695: CALL MPI_SEND (buf_int_i4(1,1), p_i4, MPI_BYTE, 1, 3, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i4(1,5), p_i4, MPI_BYTE, 1, 4, &
MPI_COMM_WORLD, p_status, p_error)
c = buf_int_i4(1,5)
700:
IF (a /= c) THEN
WRITE (nerr,'(a)') &
' Warning: MPI_INTEGER4 and MPI_BYTE not equivalent'
WRITE (nerr,'(a)') ' Using MPI_INTEGER4 anyway'
705: END IF
p_type = MPI_INTEGER4
ELSE
710: CALL MPI_SEND (MPI_INTEGER8, 1, MPI_INTEGER, 1, 0, &
MPI_COMM_WORLD, p_error)
CALL MPI_SEND (buf_int_i4(1,1), 1, MPI_INTEGER8, 1, 5, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i4(1,5), 1, MPI_INTEGER8, 1, 6, &
715: MPI_COMM_WORLD, p_status, p_error)
b = buf_int_i4(1,5)
IF (a == b) THEN
CALL MPI_SEND (buf_int_i4(1,1), p_i4, MPI_BYTE, 1, 7, &
720: MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i4(1,5), p_i4, MPI_BYTE, 1, 8, &
MPI_COMM_WORLD, p_status, p_error)
c = buf_int_i4(1,5)
725: IF (a /= c) THEN
WRITE (nerr,'(a)') &
' Warning: MPI_INTEGER8 and MPI_BYTE not equivalent'
WRITE (nerr,'(a)') &
' Using MPI_INTEGER8 anyway'
730: END IF
p_type = MPI_INTEGER8
END IF
735: END IF
END IF
IF (mype == 1) THEN
CALL MPI_RECV (buf_int_i4(1,7), 1, MPI_INTEGER4, 0, 1, &
740: MPI_COMM_WORLD, p_status, p_error)
buf_int_i4(1,3) = buf_int_i4(1,7)
CALL MPI_SEND (buf_int_i4(1,3), 1, MPI_INTEGER4, 0, 2, &
MPI_COMM_WORLD, p_error)
745: CALL MPI_RECV (datatype, 1, MPI_INTEGER, 0, 0, &
MPI_COMM_WORLD, p_status, p_error)
IF (datatype == MPI_BYTE) THEN
CALL MPI_RECV (buf_int_i4(1,7), p_i4, MPI_BYTE, 0, 3, &
750: MPI_COMM_WORLD, p_status, p_error)
buf_int_i4(1,3) = buf_int_i4(1,7)
CALL MPI_SEND (buf_int_i4(1,3), p_i4, MPI_BYTE, 0, 4, &
MPI_COMM_WORLD, p_error)
ELSE IF (datatype == MPI_INTEGER8) THEN
755: CALL MPI_RECV (buf_int_i4(1,7), 1, MPI_INTEGER8, 0, 5, &
MPI_COMM_WORLD, p_status, p_error)
buf_int_i4(1,3) = buf_int_i4(1,7)
CALL MPI_SEND (buf_int_i4(1,3), 1, MPI_INTEGER8, 0, 6, &
MPI_COMM_WORLD, p_error)
760: END IF
IF (datatype == MPI_INTEGER8) THEN
CALL MPI_RECV (buf_int_i4(1,7), p_i4, MPI_BYTE, 0, 7, &
MPI_COMM_WORLD, p_status, p_error)
765: buf_int_i4(1,3) = buf_int_i4(1,7)
CALL MPI_SEND (buf_int_i4(1,3), p_i4, MPI_BYTE, 0, 8, &
MPI_COMM_WORLD, p_error)
END IF
END IF
770: #else
p_type = 0
#endif
END FUNCTION check_type_i4
775:
FUNCTION check_type_i8 () RESULT (p_type)
INTEGER :: p_type
780: #ifndef NOMPI
INTEGER (i8) :: buf_int_i8(1,8)
INTEGER (i8) :: a, b, c
p_type = MPI_DATATYPE_NULL
785:
IF (mype == 0) THEN
a = HUGE(a)
buf_int_i8(1,1) = a
790:
CALL MPI_SEND (buf_int_i8(1,1), 1, MPI_INTEGER8, 1, 1, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i8(1,5), 1, MPI_INTEGER8, 1, 2, &
MPI_COMM_WORLD, p_status, p_error)
795: b = buf_int_i8(1,5)
IF (a == b) THEN
CALL MPI_SEND (buf_int_i8(1,1), p_i8, MPI_BYTE, 1, 3, &
MPI_COMM_WORLD, p_error)
800: CALL MPI_RECV (buf_int_i8(1,5), p_i8, MPI_BYTE, 1, 4, &
MPI_COMM_WORLD, p_status, p_error)
c = buf_int_i8(1,5)
IF (a /= c) THEN
805: WRITE (nerr,'(a)') &
' Warning: MPI_INTEGER8 and MPI_BYTE not equivalent'
WRITE (nerr,'(a)') ' Using MPI_INTEGER8 anyway'
END IF
810: p_type = MPI_INTEGER8
ELSE
WRITE (nerr,'(a)') ' MPI_INTEGER8 not available.'
END IF
815: END IF
IF (mype == 1) THEN
CALL MPI_RECV (buf_int_i8(1,7), 1, MPI_INTEGER8, 0, 1, &
MPI_COMM_WORLD, p_status, p_error)
820: buf_int_i8(1,3) = buf_int_i8(1,7)
CALL MPI_SEND (buf_int_i8(1,3), 1, MPI_INTEGER8, 0, 2, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_int_i8(1,7), p_i8, MPI_BYTE, 0, 3, &
825: MPI_COMM_WORLD, p_status, p_error)
buf_int_i8(1,3) = buf_int_i8(1,7)
CALL MPI_SEND (buf_int_i8(1,3), p_i8, MPI_BYTE, 0, 4, &
MPI_COMM_WORLD, p_error)
END IF
830: #else
p_type = 0
#endif
END FUNCTION check_type_i8
835:
FUNCTION check_type_sp () RESULT (p_type)
INTEGER :: p_type
840: #ifndef NOMPI
INTEGER :: datatype
REAL (sp) :: buf_real_sp(1,8)
REAL (sp) :: a, b, c
845:
p_type = MPI_DATATYPE_NULL
IF (mype == 0) THEN
850: a = HUGE(a)
buf_real_sp(1,1) = a
CALL MPI_SEND (buf_real_sp(1,1), 1, MPI_REAL, 1, 1, &
MPI_COMM_WORLD, p_error)
855: CALL MPI_RECV (buf_real_sp(1,5), 1, MPI_REAL, 1, 2, &
MPI_COMM_WORLD, p_status, p_error)
b = buf_real_sp(1,5)
IF (a == b) THEN
860: CALL MPI_SEND (MPI_BYTE, 1, MPI_INTEGER, 1, 0, &
MPI_COMM_WORLD, p_error)
CALL MPI_SEND (buf_real_sp(1,1), p_sp, MPI_BYTE, 1, 3, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_real_sp(1,5), p_sp, MPI_BYTE, 1, 4, &
865: MPI_COMM_WORLD, p_status, p_error)
c = buf_real_sp(1,5)
IF (a /= c) THEN
WRITE (nerr,'(a)') ' Warning: MPI_REAL and MPI_BYTE not equivalent'
870: WRITE (nerr,'(a)') ' Using MPI_REAL anyway'
END IF
p_type = MPI_REAL
875: ELSE
CALL MPI_SEND (MPI_DOUBLE_PRECISION, 1, MPI_INTEGER, 1, 0, &
MPI_COMM_WORLD, p_error)
CALL MPI_SEND (buf_real_sp(1,1), 1, MPI_DOUBLE_PRECISION, 1, 5, &
MPI_COMM_WORLD, p_error)
880: CALL MPI_RECV (buf_real_sp(1,5), 1, MPI_DOUBLE_PRECISION, 1, 6, &
MPI_COMM_WORLD, p_status, p_error)
b = buf_real_sp(1,5)
IF (a == b) THEN
885: CALL MPI_SEND (buf_real_sp(1,1), p_sp, MPI_BYTE, 1, 7, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_real_sp(1,5), p_sp, MPI_BYTE, 1, 8, &
MPI_COMM_WORLD, p_status, p_error)
c = buf_real_sp(1,5)
890:
IF (a /= c) THEN
WRITE (nerr,'(a,a)') &
' Warning: MPI_DOUBLE_PRECISION and MPI_BYTE ', &
'not equivalent'
895: WRITE (nerr,'(a)') &
' Using MPI_DOUBLE_PRECISION anyway'
END IF
p_type = MPI_DOUBLE_PRECISION
900:
END IF
END IF
END IF
905: IF (mype == 1) THEN
CALL MPI_RECV (buf_real_sp(1,7), 1, MPI_REAL, 0, 1, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_sp(1,3) = buf_real_sp(1,7)
CALL MPI_SEND (buf_real_sp(1,3), 1, MPI_REAL, 0, 2, &
910: MPI_COMM_WORLD, p_error)
CALL MPI_RECV (datatype, 1, MPI_INTEGER, 0, 0, &
MPI_COMM_WORLD, p_status, p_error)
915: IF (datatype == MPI_BYTE) THEN
CALL MPI_RECV (buf_real_sp(1,7), p_sp, MPI_BYTE, 0, 3, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_sp(1,3) = buf_real_sp(1,7)
CALL MPI_SEND (buf_real_sp(1,3), p_sp, MPI_BYTE, 0, 4, &
920: MPI_COMM_WORLD, p_error)
ELSE IF (datatype == MPI_DOUBLE_PRECISION) THEN
CALL MPI_RECV (buf_real_sp(1,7), 1, MPI_DOUBLE_PRECISION, 0, 5, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_sp(1,3) = buf_real_sp(1,7)
925: CALL MPI_SEND (buf_real_sp(1,3), 1, MPI_DOUBLE_PRECISION, 0, 6, &
MPI_COMM_WORLD, p_error)
END IF
IF (datatype == MPI_DOUBLE_PRECISION) THEN
930: CALL MPI_RECV (buf_real_sp(1,7), p_sp, MPI_BYTE, 0, 7, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_sp(1,3) = buf_real_sp(1,7)
CALL MPI_SEND (buf_real_sp(1,3), p_sp, MPI_BYTE, 0, 8, &
MPI_COMM_WORLD, p_error)
935: END IF
END IF
#else
p_type = 0
#endif
940:
END FUNCTION check_type_sp
FUNCTION check_type_dp () RESULT (p_type)
945: INTEGER :: p_type
#ifndef NOMPI
REAL (dp) :: buf_real_dp(1,8)
REAL (dp) :: a, b, c
950:
p_type = MPI_DATATYPE_NULL
IF (mype == 0) THEN
955: a = HUGE(a)
buf_real_dp(1,1) = a
CALL MPI_SEND (buf_real_dp(1,1), 1, MPI_DOUBLE_PRECISION, 1, 1, &
MPI_COMM_WORLD, p_error)
960: CALL MPI_RECV (buf_real_dp(1,5), 1, MPI_DOUBLE_PRECISION, 1, 2, &
MPI_COMM_WORLD, p_status, p_error)
b = buf_real_dp(1,5)
IF (a == b) THEN
965: CALL MPI_SEND (buf_real_dp(1,1), p_dp, MPI_BYTE, 1, 3, &
MPI_COMM_WORLD, p_error)
CALL MPI_RECV (buf_real_dp(1,5), p_dp, MPI_BYTE, 1, 4, &
MPI_COMM_WORLD, p_status, p_error)
c = buf_real_dp(1,5)
970:
IF (a /= c) THEN
WRITE (nerr,'(a)') &
' Warning: MPI_DOUBLE_PRECISION and MPI_BYTE not equivalent'
WRITE (nerr,'(a)') ' Using MPI_DOUBLE_PRECISION anyway'
975: END IF
p_type = MPI_DOUBLE_PRECISION
ELSE
980: WRITE (nerr,'(a)') ' MPI_DOUBLE_PRECISION not available.'
END IF
END IF
IF (mype == 1) THEN
985: CALL MPI_RECV (buf_real_dp(1,7), 1, MPI_DOUBLE_PRECISION, 0, 1, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_dp(1,3) = buf_real_dp(1,7)
CALL MPI_SEND (buf_real_dp(1,3), 1, MPI_DOUBLE_PRECISION, 0, 2, &
MPI_COMM_WORLD, p_error)
990:
CALL MPI_RECV (buf_real_dp(1,7), p_dp, MPI_BYTE, 0, 3, &
MPI_COMM_WORLD, p_status, p_error)
buf_real_dp(1,3) = buf_real_dp(1,7)
CALL MPI_SEND (buf_real_dp(1,3), p_dp, MPI_BYTE, 0, 4, &
995: MPI_COMM_WORLD, p_error)
END IF
#else
p_type = 0
#endif
1000:
END FUNCTION check_type_dp
! communicator set up
1005: SUBROUTINE p_set_communicator (nproca, nprocb, mapmesh, debug_parallel)
INTEGER, INTENT(in) :: nproca, nprocb
INTEGER, INTENT(in) :: mapmesh(0:,0:)
INTEGER, INTENT(in) :: debug_parallel
1010:
#ifndef NOMPI
INTEGER :: all_debug_pes(SIZE(mapmesh))
INTEGER :: group_world, group_a, group_b, group_d
1015: INTEGER :: p_communicator_tmp
INTEGER :: n, members
! first set global group
1020:
CALL MPI_COMM_GROUP (MPI_COMM_WORLD, group_world, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_GROUP failed.'
1025: WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
1030: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
1035: ! communicator is MPI_COMM_WORLD
IF (debug_parallel >= 0 ) THEN
CALL MPI_GROUP_INCL (group_world, 1, 0, group_d, p_error)
1040:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_GROUP_INCL failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
1045:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1050: END IF
END IF
CALL MPI_COMM_CREATE (MPI_COMM_WORLD, group_d, p_communicator_tmp, &
p_error)
1055:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_CREATE failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
1060:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1065: END IF
END IF
IF (mype == 0) p_communicator_d = p_communicator_tmp
1070: DO n = 1, SIZE(mapmesh)
all_debug_pes(n) = n
END DO
CALL MPI_GROUP_INCL (group_world, SIZE(mapmesh), all_debug_pes, &
1075: group_d, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_GROUP_INCL failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1080: CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1085: STOP
END IF
END IF
CALL MPI_COMM_CREATE (MPI_COMM_WORLD, group_d, p_communicator_tmp, &
1090: p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_CREATE failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1095: CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1100: STOP
END IF
END IF
IF (mype /= 0) p_communicator_d = p_communicator_tmp
1105:
ELSE
p_communicator_d = MPI_COMM_WORLD
END IF
1110: DO n = 0, nproca-1
members = nprocb
CALL MPI_GROUP_INCL (group_world, members, mapmesh(:,n), group_a, &
p_error)
1115: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_GROUP_INCL failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
1120: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1125: END IF
CALL MPI_COMM_CREATE (MPI_COMM_WORLD, group_a, p_communicator_tmp, &
p_error)
1130: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_CREATE failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
1135: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1140: END IF
IF(p_communicator_tmp/=MPI_COMM_NULL) &
p_communicator_a = p_communicator_tmp
END DO
1145:
! create groups for set Bs
DO n = 0, nprocb-1
members = nproca
1150: CALL MPI_GROUP_INCL (group_world, members, mapmesh(n,:), group_b, &
p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_GROUP_INCL failed.'
1155: WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
1160: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
1165: CALL MPI_COMM_CREATE (MPI_COMM_WORLD, group_b, p_communicator_tmp, &
p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_COMM_CREATE failed.'
1170: WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
1175: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
END IF
IF(p_communicator_tmp/=MPI_COMM_NULL) &
1180: p_communicator_b = p_communicator_tmp
END DO
CALL MPI_BARRIER (MPI_COMM_WORLD, p_error)
1185:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' PE: ', mype, ' MPI_BARRIER failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
CALL MPI_ABORT (MPI_COMM_WORLD, 0, p_error)
1190:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a)') ' MPI_ABORT failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1195: END IF
END IF
IF (debug_parallel >= 0 .AND. mype == 0) THEN
p_communicator_a = p_communicator_d
1200: p_communicator_b = p_communicator_d
ENDIF
WRITE (nerr,'(a,i4,a,3i8)') &
'p_set_communicator on PE ', mype, ': ', &
1205: p_communicator_d, &
p_communicator_a, &
p_communicator_b
#endif
END SUBROUTINE p_set_communicator
1210:
!=========================================================================
! send implementation
1215: SUBROUTINE p_send_real (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1220: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1225: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1230: CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, 1, p_real, p_destination, p_tag, &
p_comm, p_error)
1235: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
1240: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1245: #endif
END SUBROUTINE p_send_real
SUBROUTINE p_send_real_1d (buffer, p_destination, p_tag, p_count, comm)
1250:
REAL (dp), INTENT(in) :: buffer(:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
1255: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
1260: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
1265: p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_error)
END IF
1270:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
1275: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
1280:
END SUBROUTINE p_send_real_1d
SUBROUTINE p_send_real_2d (buffer, p_destination, p_tag, p_count, comm)
1285: REAL (dp), INTENT(in) :: buffer(:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1290:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
1295: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_error)
1300: ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_error)
END IF
1305: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1310: STOP
END IF
#endif
#endif
1315: END SUBROUTINE p_send_real_2d
SUBROUTINE p_send_real_3d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:,:,:)
1320: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1325: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1330:
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_error)
ELSE
1335: CALL MPI_SEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_error)
END IF
#ifdef DEBUG
1340: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1345: END IF
#endif
#endif
END SUBROUTINE p_send_real_3d
1350:
SUBROUTINE p_send_real_4d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
1355: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
1360: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1365: IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
1370: p_comm, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
1375: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1380: #endif
#endif
END SUBROUTINE p_send_real_4d
1385: SUBROUTINE p_send_real_5d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:,:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1390: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1395: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1400: CALL MPI_SEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_error)
1405: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
1410: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1415: #endif
END SUBROUTINE p_send_real_5d
SUBROUTINE p_send_int (buffer, p_destination, p_tag, p_count, comm)
1420:
INTEGER, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
1425: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
1430: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_int, p_destination, p_tag, &
1435: p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, 1, p_int, p_destination, p_tag, &
p_comm, p_error)
END IF
1440:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
1445: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
1450:
END SUBROUTINE p_send_int
SUBROUTINE p_send_int_1d (buffer, p_destination, p_tag, p_count, comm)
1455: INTEGER, INTENT(in) :: buffer(:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1460:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
1465: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_error)
1470: ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_error)
END IF
1475: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1480: STOP
END IF
#endif
#endif
1485: END SUBROUTINE p_send_int_1d
SUBROUTINE p_send_int_2d (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer(:,:)
1490: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1495: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1500:
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_error)
ELSE
1505: CALL MPI_SEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_error)
END IF
#ifdef DEBUG
1510: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1515: END IF
#endif
#endif
END SUBROUTINE p_send_int_2d
1520:
SUBROUTINE p_send_int_3d (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer(:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
1525: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
1530: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1535: IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
1540: p_comm, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
1545: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1550: #endif
#endif
END SUBROUTINE p_send_int_3d
1555: SUBROUTINE p_send_int_4d (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1560: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1565: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1570: CALL MPI_SEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_error)
1575: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
1580: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1585: #endif
END SUBROUTINE p_send_int_4d
1590: SUBROUTINE p_send_bool (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1595: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1600: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1605: CALL MPI_SEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, 1, p_bool, p_destination, p_tag, &
p_comm, p_error)
1610: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
1615: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1620: #endif
END SUBROUTINE p_send_bool
SUBROUTINE p_send_bool_1d (buffer, p_destination, p_tag, p_count, comm)
1625:
LOGICAL, INTENT(in) :: buffer(:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
1630: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
1635: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_bool, p_destination, p_tag, &
1640: p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_error)
END IF
1645:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
1650: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
1655:
END SUBROUTINE p_send_bool_1d
SUBROUTINE p_send_bool_2d (buffer, p_destination, p_tag, p_count, comm)
1660: LOGICAL, INTENT(in) :: buffer(:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1665:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
1670: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_error)
1675: ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_error)
END IF
1680: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1685: STOP
END IF
#endif
#endif
1690: END SUBROUTINE p_send_bool_2d
SUBROUTINE p_send_bool_3d (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer(:,:,:)
1695: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1700: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1705:
IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_error)
ELSE
1710: CALL MPI_SEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_error)
END IF
#ifdef DEBUG
1715: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
1720: END IF
#endif
#endif
END SUBROUTINE p_send_bool_3d
1725:
SUBROUTINE p_send_bool_4d (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
1730: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
1735: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1740: IF (PRESENT(p_count)) THEN
CALL MPI_SEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
1745: p_comm, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
1750: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1755: #endif
#endif
END SUBROUTINE p_send_bool_4d
1760: SUBROUTINE p_send_char (buffer, p_destination, p_tag, p_count, comm)
CHARACTER (*), INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1765: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1770: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1775: CALL MPI_SEND (buffer, p_count, p_char, p_destination, p_tag, &
p_comm, p_error)
ELSE
CALL MPI_SEND (buffer, LEN(buffer), p_char, p_destination, p_tag, &
p_comm, p_error)
1780: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_SEND from ', mype, &
1785: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1790: #endif
END SUBROUTINE p_send_char
! non-blocking sends
1795:
SUBROUTINE p_isend_real (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
1800: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
1805: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1810: IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
1815: CALL MPI_ISEND (buffer, 1, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
1820: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1825: STOP
END IF
#endif
#endif
1830: END SUBROUTINE p_isend_real
SUBROUTINE p_isend_real_1d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:)
1835: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1840: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1845:
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
1850: ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
1855:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
1860: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
1865:
END SUBROUTINE p_isend_real_1d
SUBROUTINE p_isend_real_2d (buffer, p_destination, p_tag, p_count, comm)
1870: REAL (dp), INTENT(in) :: buffer(:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
1875: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
1880: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
1885: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
1890: p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
1895: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
1900: #endif
#endif
END SUBROUTINE p_isend_real_2d
1905: SUBROUTINE p_isend_real_3d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1910:
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
1915: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
1920: IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
1925: CALL MPI_ISEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
1930: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
1935: STOP
END IF
#endif
#endif
1940: END SUBROUTINE p_isend_real_3d
SUBROUTINE p_isend_real_4d (buffer, p_destination, p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer(:,:,:,:)
1945: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
1950:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
1955: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
1960: p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
1965: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
1970: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
1975: #endif
END SUBROUTINE p_isend_real_4d
SUBROUTINE p_isend_real_5d (buffer, p_destination, p_tag, p_count, comm)
1980:
REAL (dp), INTENT(in) :: buffer(:,:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
1985: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
1990: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
1995: CALL MPI_ISEND (buffer, p_count, p_real, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_real, p_destination, p_tag, &
2000: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
2005: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
2010: END IF
#endif
#endif
END SUBROUTINE p_isend_real_5d
2015:
SUBROUTINE p_isend_int (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
2020: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2025: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2030:
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
2035: ELSE
CALL MPI_ISEND (buffer, 1, p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2040:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
2045: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2050:
END SUBROUTINE p_isend_int
SUBROUTINE p_isend_int_1d (buffer, p_destination, p_tag, p_count, comm)
2055: INTEGER, INTENT(in) :: buffer(:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2060: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2065: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_int, p_destination, p_tag, &
2070: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
2075: p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2080: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2085: #endif
#endif
END SUBROUTINE p_isend_int_1d
2090: SUBROUTINE p_isend_int_2d (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer(:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2095:
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
2100: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2105: IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
2110: CALL MPI_ISEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2115: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
2120: STOP
END IF
#endif
#endif
2125: END SUBROUTINE p_isend_int_2d
SUBROUTINE p_isend_int_3d (buffer, p_destination, p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer(:,:,:)
2130: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2135: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2140:
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
2145: ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2150:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
2155: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2160:
END SUBROUTINE p_isend_int_3d
SUBROUTINE p_isend_int_4d (buffer, p_destination, p_tag, p_count, comm)
2165: INTEGER, INTENT(in) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2170: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2175: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_int, p_destination, p_tag, &
2180: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_int, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
2185: p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2190: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2195: #endif
#endif
END SUBROUTINE p_isend_int_4d
2200:
SUBROUTINE p_isend_bool (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
2205: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2210: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2215:
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
2220: ELSE
CALL MPI_ISEND (buffer, 1, p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2225:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
2230: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2235:
END SUBROUTINE p_isend_bool
SUBROUTINE p_isend_bool_1d (buffer, p_destination, p_tag, p_count, comm)
2240: LOGICAL, INTENT(in) :: buffer(:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2245: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2250: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_bool, p_destination, p_tag, &
2255: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
2260: p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2265: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2270: #endif
#endif
END SUBROUTINE p_isend_bool_1d
2275: SUBROUTINE p_isend_bool_2d (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer(:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2280:
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
2285: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2290: IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
2295: CALL MPI_ISEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2300: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
2305: STOP
END IF
#endif
#endif
2310: END SUBROUTINE p_isend_bool_2d
SUBROUTINE p_isend_bool_3d (buffer, p_destination, p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer(:,:,:)
2315: INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2320:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
2325: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
2330: p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
2335: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
2340: ' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
2345: #endif
END SUBROUTINE p_isend_bool_3d
SUBROUTINE p_isend_bool_4d (buffer, p_destination, p_tag, p_count, comm)
2350:
LOGICAL, INTENT(in) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_destination, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2355: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2360: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2365: CALL MPI_ISEND (buffer, p_count, p_bool, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
ELSE
CALL MPI_ISEND (buffer, SIZE(buffer), p_bool, p_destination, p_tag, &
2370: p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
#ifdef DEBUG
2375: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
2380: END IF
#endif
#endif
END SUBROUTINE p_isend_bool_4d
2385:
SUBROUTINE p_isend_char (buffer, p_destination, p_tag, p_count, comm)
CHARACTER (*), INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_destination, p_tag
2390: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2395: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2400:
IF (PRESENT(p_count)) THEN
CALL MPI_ISEND (buffer, p_count, p_char, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
2405: ELSE
CALL MPI_ISEND (buffer, LEN(buffer), p_char, p_destination, p_tag, &
p_comm, p_request(p_irequest), p_error)
p_irequest = p_irequest + 1
END IF
2410:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_ISEND from ', mype, &
' to ', p_destination, ' for tag ', p_tag, ' failed.'
2415: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2420:
END SUBROUTINE p_isend_char
! recv implementation
2425: SUBROUTINE p_recv_real (buffer, p_source, p_tag, p_count, comm)
REAL (dp), INTENT(out) :: buffer
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2430: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2435: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2440: CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, 1, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
2445: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
2450: ' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
2455: #endif
END SUBROUTINE p_recv_real
SUBROUTINE p_recv_real_1d (buffer, p_source, p_tag, p_count, comm)
2460:
REAL (dp), INTENT(out) :: buffer(:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2465: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2470: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
2475: p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_real, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2480:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
2485: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2490:
END SUBROUTINE p_recv_real_1d
SUBROUTINE p_recv_real_2d (buffer, p_source, p_tag, p_count, comm)
2495: REAL (dp), INTENT(out) :: buffer(:,:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2500:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
2505: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
2510: ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_real, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2515: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
2520: STOP
END IF
#endif
#endif
2525: END SUBROUTINE p_recv_real_2d
SUBROUTINE p_recv_real_3d (buffer, p_source, p_tag, p_count, comm)
REAL (dp), INTENT(out) :: buffer(:,:,:)
2530: INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2535: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2540:
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
2545: CALL MPI_RECV (buffer, SIZE(buffer), p_real, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
#ifdef DEBUG
2550: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
2555: END IF
#endif
#endif
END SUBROUTINE p_recv_real_3d
2560:
SUBROUTINE p_recv_real_4d (buffer, p_source, p_tag, p_count, comm)
REAL (dp), INTENT(out) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source, p_tag
2565: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
2570: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2575: IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_real, p_source, p_tag, &
2580: p_comm, p_status, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2585: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2590: #endif
#endif
END SUBROUTINE p_recv_real_4d
2595: SUBROUTINE p_recv_real_5d (buffer, p_source, p_tag, p_count, comm)
REAL (dp), INTENT(out) :: buffer(:,:,:,:,:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2600: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2605: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2610: CALL MPI_RECV (buffer, p_count, p_real, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_real, p_source, p_tag, &
p_comm, p_status, p_error)
2615: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
2620: ' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
2625: #endif
END SUBROUTINE p_recv_real_5d
SUBROUTINE p_recv_int (buffer, p_source, p_tag, p_count, comm)
2630:
INTEGER, INTENT(out) :: buffer
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2635: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2640: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_int, p_source, p_tag, &
2645: p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, 1, p_int, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2650:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
2655: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2660:
END SUBROUTINE p_recv_int
SUBROUTINE p_recv_int_1d (buffer, p_source, p_tag, p_count, comm)
2665: INTEGER, INTENT(out) :: buffer(:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2670:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
2675: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_int, p_source, p_tag, &
p_comm, p_status, p_error)
2680: ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_int, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2685: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
2690: STOP
END IF
#endif
#endif
2695: END SUBROUTINE p_recv_int_1d
SUBROUTINE p_recv_int_2d (buffer, p_source, p_tag, p_count, comm)
INTEGER, INTENT(out) :: buffer(:,:)
2700: INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2705: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2710:
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_int, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
2715: CALL MPI_RECV (buffer, SIZE(buffer), p_int, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
#ifdef DEBUG
2720: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
2725: END IF
#endif
#endif
END SUBROUTINE p_recv_int_2d
2730:
SUBROUTINE p_recv_int_3d (buffer, p_source, p_tag, p_count, comm)
INTEGER, INTENT(out) :: buffer(:,:,:)
INTEGER, INTENT(in) :: p_source, p_tag
2735: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
2740: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2745: IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_int, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_int, p_source, p_tag, &
2750: p_comm, p_status, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2755: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2760: #endif
#endif
END SUBROUTINE p_recv_int_3d
2765: SUBROUTINE p_recv_int_4d (buffer, p_source, p_tag, p_count, comm)
INTEGER, INTENT(out) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2770: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2775: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2780: CALL MPI_RECV (buffer, p_count, p_int, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_int, p_source, p_tag, &
p_comm, p_status, p_error)
2785: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
2790: ' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
2795: #endif
END SUBROUTINE p_recv_int_4d
2800: SUBROUTINE p_recv_bool (buffer, p_source, p_tag, p_count, comm)
LOGICAL, INTENT(out) :: buffer
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2805: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2810: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2815: CALL MPI_RECV (buffer, p_count, p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, 1, p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
2820: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
2825: ' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
2830: #endif
END SUBROUTINE p_recv_bool
SUBROUTINE p_recv_bool_1d (buffer, p_source, p_tag, p_count, comm)
2835:
LOGICAL, INTENT(out) :: buffer(:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
2840: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
2845: p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_bool, p_source, p_tag, &
2850: p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2855:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
2860: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
2865:
END SUBROUTINE p_recv_bool_1d
SUBROUTINE p_recv_bool_2d (buffer, p_source, p_tag, p_count, comm)
2870: LOGICAL, INTENT(out) :: buffer(:,:)
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2875:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
2880: ENDIF
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
2885: ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
2890: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
2895: STOP
END IF
#endif
#endif
2900: END SUBROUTINE p_recv_bool_2d
SUBROUTINE p_recv_bool_3d (buffer, p_source, p_tag, p_count, comm)
LOGICAL, INTENT(out) :: buffer(:,:,:)
2905: INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
2910: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2915:
IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
2920: CALL MPI_RECV (buffer, SIZE(buffer), p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
END IF
#ifdef DEBUG
2925: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
2930: END IF
#endif
#endif
END SUBROUTINE p_recv_bool_3d
2935:
SUBROUTINE p_recv_bool_4d (buffer, p_source, p_tag, p_count, comm)
LOGICAL, INTENT(out) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source, p_tag
2940: INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
2945: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
2950: IF (PRESENT(p_count)) THEN
CALL MPI_RECV (buffer, p_count, p_bool, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, SIZE(buffer), p_bool, p_source, p_tag, &
2955: p_comm, p_status, p_error)
END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
2960: WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
2965: #endif
#endif
END SUBROUTINE p_recv_bool_4d
2970: SUBROUTINE p_recv_char (buffer, p_source, p_tag, p_count, comm)
CHARACTER (*), INTENT(out) :: buffer
INTEGER, INTENT(in) :: p_source, p_tag
INTEGER, OPTIONAL, INTENT(in) :: p_count, comm
2975: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
2980: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (PRESENT(p_count)) THEN
2985: CALL MPI_RECV (buffer, p_count, p_char, p_source, p_tag, &
p_comm, p_status, p_error)
ELSE
CALL MPI_RECV (buffer, LEN(buffer), p_char, p_source, p_tag, &
p_comm, p_status, p_error)
2990: END IF
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_RECV on ', mype, &
2995: ' from ', p_source, ' for tag ', p_tag, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
3000: #endif
END SUBROUTINE p_recv_char
! bcast implementation
3005:
SUBROUTINE p_bcast_real (buffer, p_source, comm)
REAL (dp), INTENT(inout) :: buffer
INTEGER, INTENT(in) :: p_source
3010: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
3015: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3020: #ifdef DEBUG
nbcast = nbcast+1
#endif
IF (npes == 1) THEN
3025: RETURN
ELSE
CALL MPI_BCAST (buffer, 1, p_real, p_source, &
p_comm, p_error)
ENDIF
3030:
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3035: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
3040: END IF
#endif
#endif
END SUBROUTINE p_bcast_real
3045:
SUBROUTINE p_bcast_real_1d (buffer, p_source, comm)
REAL (dp), INTENT(inout) :: buffer(:)
INTEGER, INTENT(in) :: p_source
3050: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
3055: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3060: #ifdef DEBUG
nbcast = nbcast+1
#endif
IF (npes == 1) THEN
3065: RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_real, p_source, &
p_comm, p_error)
ENDIF
3070:
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3075: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
3080: END IF
#endif
#endif
END SUBROUTINE p_bcast_real_1d
3085:
SUBROUTINE p_bcast_real_2d (buffer, p_source, comm)
REAL (dp), INTENT(inout) :: buffer(:,:)
INTEGER, INTENT(in) :: p_source
3090: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3095: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3100:
#ifdef DEBUG
nbcast = nbcast+1
#endif
3105: IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_real, p_source, &
p_comm, p_error)
3110: ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3115:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3120: STOP
END IF
#endif
#endif
3125: END SUBROUTINE p_bcast_real_2d
SUBROUTINE p_bcast_real_3d (buffer, p_source, comm)
REAL (dp), INTENT(inout) :: buffer(:,:,:)
3130: INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3135:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
3140: ENDIF
#ifdef DEBUG
nbcast = nbcast+1
#endif
3145:
IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_real, p_source, &
3150: p_comm, p_error)
ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
3155: ' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
3160: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
3165:
END SUBROUTINE p_bcast_real_3d
SUBROUTINE p_bcast_real_4d (buffer, p_source, comm)
3170: REAL (dp), INTENT(inout) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
3175: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3180: p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
nbcast = nbcast+1
3185: #endif
IF (npes == 1) THEN
RETURN
ELSE
3190: CALL MPI_BCAST (buffer, SIZE(buffer), p_real, p_source, &
p_comm, p_error)
ENDIF
#ifdef DEBUG
3195: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
3200: ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
3205: #endif
END SUBROUTINE p_bcast_real_4d
SUBROUTINE p_bcast_int_i4 (buffer, p_source, comm)
3210:
INTEGER (i4), INTENT(inout) :: buffer
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
3215: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
3220: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
3225: nbcast = nbcast+1
#endif
IF (npes == 1) THEN
RETURN
3230: ELSE
CALL MPI_BCAST (buffer, 1, p_int_i4, p_source, &
p_comm, p_error)
ENDIF
3235: #ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
3240: WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3245: #endif
#endif
END SUBROUTINE p_bcast_int_i4
3250: SUBROUTINE p_bcast_int_i8 (buffer, p_source, comm)
INTEGER (i8), INTENT(inout) :: buffer
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
3255:
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
3260: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3265: #ifdef DEBUG
nbcast = nbcast+1
#endif
IF (npes == 1) THEN
3270: RETURN
ELSE
CALL MPI_BCAST (buffer, 1, p_int_i8, p_source, &
p_comm, p_error)
ENDIF
3275:
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3280: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
3285: END IF
#endif
#endif
END SUBROUTINE p_bcast_int_i8
3290:
SUBROUTINE p_bcast_int_1d (buffer, p_source, comm)
INTEGER, INTENT(inout) :: buffer(:)
INTEGER, INTENT(in) :: p_source
3295: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3300: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3305:
#ifdef DEBUG
nbcast = nbcast+1
#endif
3310: IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_int, p_source, &
p_comm, p_error)
3315: ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3320:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3325: STOP
END IF
#endif
#endif
3330: END SUBROUTINE p_bcast_int_1d
SUBROUTINE p_bcast_int_2d (buffer, p_source, comm)
INTEGER, INTENT(inout) :: buffer(:,:)
3335: INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3340:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
3345: ENDIF
#ifdef DEBUG
nbcast = nbcast+1
#endif
3350:
IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_int, p_source, &
3355: p_comm, p_error)
ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
3360: ' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
3365: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
3370:
END SUBROUTINE p_bcast_int_2d
SUBROUTINE p_bcast_int_3d (buffer, p_source, comm)
3375: INTEGER, INTENT(inout) :: buffer(:,:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
3380: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3385: p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
nbcast = nbcast+1
3390: #endif
IF (npes == 1) THEN
RETURN
ELSE
3395: CALL MPI_BCAST (buffer, SIZE(buffer), p_int, p_source, &
p_comm, p_error)
ENDIF
#ifdef DEBUG
3400: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
3405: ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
3410: #endif
END SUBROUTINE p_bcast_int_3d
SUBROUTINE p_bcast_int_4d (buffer, p_source, comm)
3415:
INTEGER, INTENT(inout) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
3420: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
3425: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
3430: nbcast = nbcast+1
#endif
IF (npes == 1) THEN
RETURN
3435: ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_int, p_source, &
p_comm, p_error)
ENDIF
3440: #ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
3445: WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3450: #endif
#endif
END SUBROUTINE p_bcast_int_4d
3455:
SUBROUTINE p_bcast_bool (buffer, p_source, comm)
LOGICAL, INTENT(inout) :: buffer
INTEGER, INTENT(in) :: p_source
3460: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3465: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3470:
#ifdef DEBUG
nbcast = nbcast+1
#endif
3475: IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, 1, p_bool, p_source, &
p_comm, p_error)
3480: ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3485:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3490: STOP
END IF
#endif
#endif
3495: END SUBROUTINE p_bcast_bool
SUBROUTINE p_bcast_bool_1d (buffer, p_source, comm)
LOGICAL, INTENT(inout) :: buffer(:)
3500: INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3505:
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
3510: ENDIF
#ifdef DEBUG
nbcast = nbcast+1
#endif
3515:
IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_bool, p_source, &
3520: p_comm, p_error)
ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
3525: ' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
3530: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
#endif
3535:
END SUBROUTINE p_bcast_bool_1d
SUBROUTINE p_bcast_bool_2d (buffer, p_source, comm)
3540: LOGICAL, INTENT(inout) :: buffer(:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
3545: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3550: p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
nbcast = nbcast+1
3555: #endif
IF (npes == 1) THEN
RETURN
ELSE
3560: CALL MPI_BCAST (buffer, SIZE(buffer), p_bool, p_source, &
p_comm, p_error)
ENDIF
#ifdef DEBUG
3565: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
3570: ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
3575: #endif
END SUBROUTINE p_bcast_bool_2d
SUBROUTINE p_bcast_bool_3d (buffer, p_source, comm)
3580:
LOGICAL, INTENT(inout) :: buffer(:,:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
3585: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
3590: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
#ifdef DEBUG
3595: nbcast = nbcast+1
#endif
IF (npes == 1) THEN
RETURN
3600: ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_bool, p_source, &
p_comm, p_error)
ENDIF
3605: #ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
IF (p_error /= MPI_SUCCESS) THEN
3610: WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3615: #endif
#endif
END SUBROUTINE p_bcast_bool_3d
3620: SUBROUTINE p_bcast_bool_4d (buffer, p_source, comm)
LOGICAL, INTENT(inout) :: buffer(:,:,:,:)
INTEGER, INTENT(in) :: p_source
INTEGER, OPTIONAL, INTENT(in) :: comm
3625:
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
3630: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3635: #ifdef DEBUG
nbcast = nbcast+1
#endif
IF (npes == 1) THEN
3640: RETURN
ELSE
CALL MPI_BCAST (buffer, SIZE(buffer), p_bool, p_source, &
p_comm, p_error)
ENDIF
3645:
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3650: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
3655: END IF
#endif
#endif
END SUBROUTINE p_bcast_bool_4d
3660:
SUBROUTINE p_bcast_char (buffer, p_source, comm)
CHARACTER (*), INTENT(inout) :: buffer
INTEGER, INTENT(in) :: p_source
3665: INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3670: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3675:
#ifdef DEBUG
nbcast = nbcast+1
#endif
3680: IF (npes == 1) THEN
RETURN
ELSE
CALL MPI_BCAST (buffer, LEN(buffer), p_char, p_source, &
p_comm, p_error)
3685: ENDIF
#ifdef DEBUG
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_BCAST from ', p_source, &
' with broadcast number ', nbcast, ' succesfull.'
3690:
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BCAST from ', p_source, &
' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3695: STOP
END IF
#endif
#endif
3700: END SUBROUTINE p_bcast_char
! probe implementation
3705:
SUBROUTINE p_probe_real (buffer, p_tagcount, p_tagtable, p_source, &
& p_tag, p_count, comm)
REAL (dp), INTENT(in) :: buffer
3710: INTEGER, INTENT(in) :: p_tagcount, p_tagtable(:)
INTEGER, INTENT(out) :: p_source, p_tag, p_count
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
3715: INTEGER :: p_comm, i
LOGICAL :: flag
IF (PRESENT(comm)) THEN
p_comm = comm
3720: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
p_tag = -1
3725: DO WHILE (p_tag == -1)
DO i = 1, p_tagcount
CALL MPI_IPROBE (MPI_ANY_SOURCE, p_tagtable(i), p_comm, &
& flag, p_status, p_error)
#ifdef DEBUG
3730: IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_IPROBE on ', mype, &
' for tag ', p_tagtable(i), ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
3735: END IF
#endif
IF (flag) THEN
p_source = p_status(MPI_SOURCE)
p_tag = p_status(MPI_TAG)
3740: CALL MPI_GET_COUNT(p_status, p_real, p_count, p_error)
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_GET_COUNT on ', mype, &
' for tag ', p_tag, ' from ' , p_source, ' failed.'
3745: WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
#endif
EXIT
3750: ELSE
p_tag = -1
END IF
END DO
END DO
3755:
#endif
END SUBROUTINE p_probe_real
3760: SUBROUTINE p_probe_int (buffer, p_tagcount, p_tagtable, p_source, &
& p_tag, p_count, comm)
INTEGER, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_tagcount, p_tagtable(:)
3765: INTEGER, INTENT(out) :: p_source, p_tag, p_count
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm, i
3770: LOGICAL :: flag
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3775: p_comm = MPI_COMM_WORLD
ENDIF
p_tag = -1
DO WHILE (p_tag == -1)
3780: DO i=1,p_tagcount
CALL MPI_IPROBE (MPI_ANY_SOURCE, p_tagtable(i), p_comm, &
& flag, p_status, p_error)
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
3785: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_IPROBE on ', mype, &
' for tag ', p_tagtable(i), ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3790: #endif
IF (flag) THEN
p_source = p_status(MPI_SOURCE)
p_tag = p_status(MPI_TAG)
CALL MPI_GET_COUNT(p_status, p_int, p_count, p_error)
3795: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_GET_COUNT on ', mype, &
' for tag ', p_tag, ' from ' , p_source, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3800: STOP
END IF
#endif
EXIT
ELSE
3805: p_tag = -1
END IF
END DO
END DO
3810:
#endif
END SUBROUTINE p_probe_int
3815: SUBROUTINE p_probe_bool (buffer, p_tagcount, p_tagtable, p_source, &
& p_tag, p_count, comm)
LOGICAL, INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_tagcount, p_tagtable(:)
3820: INTEGER, INTENT(out) :: p_source, p_tag, p_count
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm, i
3825: LOGICAL :: flag
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3830: p_comm = MPI_COMM_WORLD
ENDIF
p_tag = -1
DO WHILE (p_tag == -1)
3835: DO i=1,p_tagcount
CALL MPI_IPROBE (MPI_ANY_SOURCE, p_tagtable(i), p_comm, &
& flag, p_status, p_error)
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
3840: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_IPROBE on ', mype, &
' for tag ', p_tagtable(i), ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3845: #endif
IF (flag) THEN
p_source = p_status(MPI_SOURCE)
p_tag = p_status(MPI_TAG)
CALL MPI_GET_COUNT(p_status, p_bool, p_count, p_error)
3850: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_GET_COUNT on ', mype, &
' for tag ', p_tag, ' from ' , p_source, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3855: STOP
END IF
#endif
EXIT
ELSE
3860: p_tag = -1
END IF
END DO
END DO
3865:
#endif
END SUBROUTINE p_probe_bool
3870: SUBROUTINE p_probe_char (buffer, p_tagcount, p_tagtable, p_source, &
& p_tag, p_count, comm)
CHARACTER (*), INTENT(in) :: buffer
INTEGER, INTENT(in) :: p_tagcount, p_tagtable(:)
3875: INTEGER, INTENT(out) :: p_source, p_tag, p_count
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm, i
3880: LOGICAL :: flag
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3885: p_comm = MPI_COMM_WORLD
ENDIF
p_tag = -1
DO WHILE (p_tag == -1)
3890: DO i=1,p_tagcount
CALL MPI_IPROBE (MPI_ANY_SOURCE, p_tagtable(i), p_comm, &
& flag, p_status, p_error)
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
3895: WRITE (nerr,'(a,i4,a,i4,a)') ' MPI_IPROBE on ', mype, &
' for tag ', p_tagtable(i), ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
STOP
END IF
3900: #endif
IF (flag) THEN
p_source = p_status(MPI_SOURCE)
p_tag = p_status(MPI_TAG)
CALL MPI_GET_COUNT(p_status, p_char, p_count, p_error)
3905: #ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a,i4,a,i6,a)') ' MPI_GET_COUNT on ', mype, &
' for tag ', p_tag, ' from ' , p_source, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3910: STOP
END IF
#endif
EXIT
ELSE
3915: p_tag = -1
END IF
END DO
END DO
3920:
#endif
END SUBROUTINE p_probe_char
3925: SUBROUTINE p_wait
#ifndef NOMPI
INTEGER :: i
DO i = 2, p_irequest
3930: CALL MPI_WAIT(p_request(i-1), p_status, p_error)
END DO
p_irequest = 1
#endif
END SUBROUTINE p_wait
3935:
SUBROUTINE p_barrier
#ifndef NOMPI
CALL MPI_BARRIER (MPI_COMM_WORLD, p_error)
3940:
#ifdef DEBUG
IF (p_error /= MPI_SUCCESS) THEN
WRITE (nerr,'(a,i4,a)') ' MPI_BARRIER on ', mype, ' failed.'
WRITE (nerr,'(a,i4)') ' Error = ', p_error
3945: STOP
END IF
#endif
#endif
3950: END SUBROUTINE p_barrier
FUNCTION p_max_0d (zfield, comm) RESULT (p_max)
REAL :: p_max
3955: REAL, INTENT(in) :: zfield
INTEGER, OPTIONAL, INTENT(in) :: comm
#ifndef NOMPI
INTEGER :: p_comm
3960: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
3965:
IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_max, 1, p_real, &
MPI_MAX, p_comm, p_error)
ELSE
3970: p_max = zfield
END IF
#else
p_max = zfield
#endif
3975:
END FUNCTION p_max_0d
FUNCTION p_max_1d (zfield, comm) RESULT (p_max)
3980: REAL, INTENT(in) :: zfield(:)
INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_max (SIZE(zfield))
#ifndef NOMPI
3985: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
3990: p_comm = MPI_COMM_WORLD
ENDIF
IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_max, SIZE(zfield), p_real, &
3995: MPI_MAX, p_comm, p_error)
ELSE
p_max = zfield
END IF
#else
4000: p_max = zfield
#endif
END FUNCTION p_max_1d
4005: FUNCTION p_max_2d (zfield, comm) RESULT (p_max)
REAL, INTENT(in) :: zfield(:,:)
INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_max (SIZE(zfield,1),SIZE(zfield,2))
4010:
INTEGER :: p_comm
#ifndef NOMPI
IF (PRESENT(comm)) THEN
4015: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
4020: IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_max, SIZE(zfield), p_real, &
MPI_MAX, p_comm, p_error)
ELSE
p_max = zfield
4025: END IF
#else
p_max = zfield
#endif
4030: END FUNCTION p_max_2d
FUNCTION p_max_3d (zfield, comm) RESULT (p_max)
REAL, INTENT(in) :: zfield(:,:,:)
4035: INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_max (SIZE(zfield,1),SIZE(zfield,2)&
,SIZE(zfield,3))
#ifndef NOMPI
4040: INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
4045: p_comm = MPI_COMM_WORLD
ENDIF
IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_max, SIZE(zfield), p_real, &
4050: MPI_MAX, p_comm, p_error)
ELSE
p_max = zfield
END IF
#else
4055: p_max = zfield
#endif
END FUNCTION p_max_3d
4060: FUNCTION p_min_0d (zfield, comm) RESULT (p_min)
REAL, INTENT(in) :: zfield
INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_min
4065: #ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
p_comm = comm
4070: ELSE
p_comm = MPI_COMM_WORLD
ENDIF
IF (p_real /= MPI_DATATYPE_NULL) THEN
4075: CALL MPI_ALLREDUCE (zfield, p_min, 1, p_real, &
MPI_MIN, p_comm, p_error)
ELSE
p_min = zfield
END IF
4080: #else
p_min = zfield
#endif
END FUNCTION p_min_0d
4085:
FUNCTION p_min_1d (zfield, comm) RESULT (p_min)
REAL, INTENT(in) :: zfield(:)
INTEGER, OPTIONAL, INTENT(in) :: comm
4090: REAL :: p_min (SIZE(zfield))
#ifndef NOMPI
INTEGER :: p_comm
4095: IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
4100:
IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_min, SIZE(zfield), p_real, &
MPI_MIN, p_comm, p_error)
ELSE
4105: p_min = zfield
END IF
#else
p_min = zfield
#endif
4110:
END FUNCTION p_min_1d
FUNCTION p_min_2d (zfield, comm) RESULT (p_min)
4115: REAL, INTENT(in) :: zfield(:,:)
INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_min (SIZE(zfield,1),SIZE(zfield,2))
INTEGER :: p_comm
4120:
#ifndef NOMPI
IF (PRESENT(comm)) THEN
p_comm = comm
ELSE
4125: p_comm = MPI_COMM_WORLD
ENDIF
IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_min, SIZE(zfield), p_real, &
4130: MPI_MIN, p_comm, p_error)
ELSE
p_min = zfield
END IF
#else
4135: p_min = zfield
#endif
END FUNCTION p_min_2d
4140: FUNCTION p_min_3d (zfield, comm) RESULT (p_min)
REAL, INTENT(in) :: zfield(:,:,:)
INTEGER, OPTIONAL, INTENT(in) :: comm
REAL :: p_min (SIZE(zfield,1),SIZE(zfield,2)&
4145: ,SIZE(zfield,3))
#ifndef NOMPI
INTEGER :: p_comm
IF (PRESENT(comm)) THEN
4150: p_comm = comm
ELSE
p_comm = MPI_COMM_WORLD
ENDIF
4155: IF (p_real /= MPI_DATATYPE_NULL) THEN
CALL MPI_ALLREDUCE (zfield, p_min, SIZE(zfield), p_real, &
MPI_MIN, p_comm, p_error)
ELSE
p_min = zfield
4160: END IF
#else
p_min = zfield
#endif
4165: END FUNCTION p_min_3d
END MODULE mo_mpi
Info Section
uses: mo_doctor, mo_kind
includes: mpif.h
calls: mpi_abort, mpi_allreduce, mpi_attr_get, mpi_barrier, mpi_bcast
mpi_comm_create, mpi_comm_group, mpi_comm_rank, mpi_comm_size, mpi_finalize
mpi_gather, mpi_get_count, mpi_get_version, mpi_group_incl, mpi_init
mpi_iprobe, mpi_isend, mpi_recv, mpi_send, mpi_wait
p_barrier
back to top
ECHAM 4 vf90 (C) 1998 Max-Planck-Institut für Meteorologie, Hamburg
Wed Nov 24 01:25:21 CST 1999
HTML derived from FORTRAN source by f2html.pl v0.3 (C) 1997,98 Beroud Jean-Marc.