Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
dkrz-sw
yaxt
Commits
a45007b6
Commit
a45007b6
authored
Dec 03, 2018
by
Moritz Hanke
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
adds fortran interface for xt_dmap
parent
3b8c515d
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
547 additions
and
2 deletions
+547
-2
src/Makefile.am
src/Makefile.am
+1
-0
src/xt_dmap_f.f90
src/xt_dmap_f.f90
+296
-0
src/yaxt.f90
src/yaxt.f90
+7
-0
src/yaxt_f2c.c
src/yaxt_f2c.c
+40
-2
tests/Makefile.am
tests/Makefile.am
+3
-0
tests/test_dmap_parallel_f.f90
tests/test_dmap_parallel_f.f90
+198
-0
tests/test_dmap_parallel_run.in
tests/test_dmap_parallel_run.in
+2
-0
No files found.
src/Makefile.am
View file @
a45007b6
...
...
@@ -163,6 +163,7 @@ libyaxt_la_SOURCES = \
xt_idxstripes_f.f90
\
xt_idxsection_f.f90
\
xt_xmap_f.f90
\
xt_dmap_f.f90
\
xt_redist_f.f90
\
xt_redist_int_i2.f90
\
xt_redist_int_i4.f90
\
...
...
src/xt_dmap_f.f90
0 → 100644
View file @
a45007b6
!>
!! @file xt_dmap_f.f90
!! @brief xt_dmap-related procedures of Fortran interface
!!
!! @copyright Copyright (C) 2018 Jörg Behrens <behrens@dkrz.de>
!! Moritz Hanke <hanke@dkrz.de>
!! Thomas Jahns <jahns@dkrz.de>
!!
!! @author Jörg Behrens <behrens@dkrz.de>
!! Moritz Hanke <hanke@dkrz.de>
!! Thomas Jahns <jahns@dkrz.de>
!!
! Keywords:
! Maintainer: Jörg Behrens <behrens@dkrz.de>
! Moritz Hanke <hanke@dkrz.de>
! Thomas Jahns <jahns@dkrz.de>
! URL: https://doc.redmine.dkrz.de/yaxt/html/
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!>
!! @example test_dmap_parallel_f.f90
MODULE
xt_dmap_base
USE
xt_core
,
ONLY
:
xt_abort
,
xt_mpi_fint_kind
,
i2
,
i4
,
i8
USE
xt_xmap_abstract
,
ONLY
:
xt_xmap
USE
xt_redist_base
,
ONLY
:
xt_redist
,
xt_redist_c2f
USE
iso_c_binding
,
ONLY
:
c_int
,
c_null_ptr
,
c_ptr
,
c_loc
,
c_associated
USE
xt_mpi
,
ONLY
:
mpi_address_kind
IMPLICIT
NONE
PRIVATE
! note: this type must not be extended to contain any other
! components, its memory pattern has to match void * exactly, which
! it does because of C constraints
TYPE
,
BIND
(
C
),
PUBLIC
::
xt_dmap
#ifndef __G95__
PRIVATE
#endif
TYPE
(
c_ptr
)
::
cptr
=
c_null_ptr
END
TYPE
xt_dmap
ENUM
,
BIND
(
C
)
ENUMERATOR
::
XT_REORDER_NONE
,
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
END
ENUM
INTEGER
,
PARAMETER
::
xt_reorder_type_kind
=
KIND
(
XT_REORDER_NONE
)
INTERFACE
! this function must not be implemented in Fortran because
! PGI 11.x chokes on that
FUNCTION
xt_dmap_f2c
(
dmap
)
BIND
(
c
,
name
=
'xt_dmap_f2c'
)
RESULT
(
p
)
IMPORT
::
c_ptr
,
xt_dmap
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
TYPE
(
c_ptr
)
::
p
END
FUNCTION
xt_dmap_f2c
END
INTERFACE
INTERFACE
xt_dmap_delete
MODULE
PROCEDURE
xt_dmap_delete_1
MODULE
PROCEDURE
xt_dmap_delete_a1d
END
INTERFACE
xt_dmap_delete
INTERFACE
SUBROUTINE
xt_dmap_delete_c
(
dmap
)
&
BIND
(
C
,
name
=
'xt_dmap_delete'
)
IMPORT
::
c_ptr
IMPLICIT
NONE
TYPE
(
c_ptr
),
VALUE
,
INTENT
(
in
)
::
dmap
END
SUBROUTINE
xt_dmap_delete_c
END
INTERFACE
INTERFACE
xt_is_null
MODULE
PROCEDURE
xt_dmap_is_null
END
INTERFACE
xt_is_null
INTERFACE
xt_dmap_repeat
MODULE
PROCEDURE
xt_dmap_repeat_a1d
MODULE
PROCEDURE
xt_dmap_repeat_i2_a1d
MODULE
PROCEDURE
xt_dmap_repeat_i4_a1d
MODULE
PROCEDURE
xt_dmap_repeat_i8_a1d
END
INTERFACE
xt_dmap_repeat
INTERFACE
SUBROUTINE
xt_dmap_repeat_f
(
dmap_f
,
num_repetitions
,
src_displacements
,
&
dst_displacements
)
BIND
(
C
,
name
=
'xt_dmap_repeat_f'
)
IMPORT
::
xt_dmap
,
c_int
,
xt_mpi_fint_kind
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap_f
INTEGER
(
c_int
),
VALUE
,
INTENT
(
in
)
::
num_repetitions
INTEGER
(
xt_mpi_fint_kind
),
INTENT
(
in
)
::
src_displacements
(
num_repetitions
)
INTEGER
(
xt_mpi_fint_kind
),
INTENT
(
in
)
::
dst_displacements
(
num_repetitions
)
END
SUBROUTINE
xt_dmap_repeat_f
END
INTERFACE
PUBLIC
::
xt_dmap_c2f
,
xt_dmap_f2c
,
xt_is_null
,
xt_dmap_delete
,
&
xt_dmap_offset_new
,
xt_dmap_generate_redist
,
xt_dmap_repeat
,
&
xt_dmap_reorder
,
xt_reorder_type_kind
,
&
XT_REORDER_NONE
,
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
CONTAINS
FUNCTION
xt_dmap_is_null
(
dmap
)
RESULT
(
p
)
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
LOGICAL
::
p
p
=
.NOT.
C_ASSOCIATED
(
dmap
%
cptr
)
END
FUNCTION
xt_dmap_is_null
FUNCTION
xt_dmap_c2f
(
dmap
)
RESULT
(
p
)
TYPE
(
c_ptr
),
INTENT
(
in
)
::
dmap
TYPE
(
xt_dmap
)
::
p
p
%
cptr
=
dmap
END
FUNCTION
xt_dmap_c2f
SUBROUTINE
xt_dmap_delete_1
(
dmap
)
TYPE
(
xt_dmap
),
INTENT
(
inout
)
::
dmap
CALL
xt_dmap_delete_c
(
dmap
%
cptr
)
dmap
%
cptr
=
c_null_ptr
END
SUBROUTINE
xt_dmap_delete_1
SUBROUTINE
xt_dmap_delete_a1d
(
dmaps
)
TYPE
(
xt_dmap
),
INTENT
(
inout
)
::
dmaps
(:)
INTEGER
::
i
,
n
n
=
SIZE
(
dmaps
)
DO
i
=
1
,
n
CALL
xt_dmap_delete_c
(
dmaps
(
i
)
%
cptr
)
dmaps
(
i
)
%
cptr
=
c_null_ptr
END
DO
END
SUBROUTINE
xt_dmap_delete_a1d
SUBROUTINE
xt_dmap_repeat_a1d
(
dmap
,
src_offsets
,
dst_offsets
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
,
INTENT
(
in
)
::
src_offsets
(:)
INTEGER
,
INTENT
(
in
)
::
dst_offsets
(:)
INTEGER
::
num_repetitions_src
,
num_repetitions_dst
num_repetitions_src
=
SIZE
(
src_offsets
)
num_repetitions_dst
=
SIZE
(
dst_offsets
)
IF
(
num_repetitions_src
/
=
num_repetitions_dst
)
&
CALL
xt_abort
(
"invalid number of repetitions"
,
&
__
FILE__
,
&
__
LINE__
)
IF
(
num_repetitions_src
<
0_c_int
.OR.
&
num_repetitions_src
>
HUGE
(
1_c_int
))
&
CALL
xt_abort
(
"invalid number of extents"
,
&
__
FILE__
,
&
__
LINE__
)
CALL
xt_dmap_repeat_f
(
&
dmap
,
INT
(
num_repetitions_src
,
c_int
),
src_offsets
,
dst_offsets
)
END
SUBROUTINE
xt_dmap_repeat_a1d
SUBROUTINE
xt_dmap_repeat_i2_a1d
(
dmap
,
num_repetitions
,
src_offsets
,
&
dst_offsets
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
(
i2
),
INTENT
(
in
)
::
num_repetitions
INTEGER
,
INTENT
(
in
)
::
src_offsets
(
num_repetitions
)
INTEGER
,
INTENT
(
in
)
::
dst_offsets
(
num_repetitions
)
IF
(
num_repetitions
<
0_c_int
.OR.
&
num_repetitions
>
HUGE
(
1_c_int
))
&
CALL
xt_abort
(
"invalid number of extents"
,
&
__
FILE__
,
&
__
LINE__
)
CALL
xt_dmap_repeat_f
(
&
dmap
,
INT
(
num_repetitions
,
c_int
),
src_offsets
,
dst_offsets
)
END
SUBROUTINE
xt_dmap_repeat_i2_a1d
SUBROUTINE
xt_dmap_repeat_i4_a1d
(
dmap
,
num_repetitions
,
src_offsets
,
&
dst_offsets
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
(
i4
),
INTENT
(
in
)
::
num_repetitions
INTEGER
,
INTENT
(
in
)
::
src_offsets
(
num_repetitions
)
INTEGER
,
INTENT
(
in
)
::
dst_offsets
(
num_repetitions
)
IF
(
num_repetitions
<
0_c_int
.OR.
&
num_repetitions
>
HUGE
(
1_c_int
))
&
CALL
xt_abort
(
"invalid number of extents"
,
&
__
FILE__
,
&
__
LINE__
)
CALL
xt_dmap_repeat_f
(
&
dmap
,
INT
(
num_repetitions
,
c_int
),
src_offsets
,
dst_offsets
)
END
SUBROUTINE
xt_dmap_repeat_i4_a1d
SUBROUTINE
xt_dmap_repeat_i8_a1d
(
dmap
,
num_repetitions
,
src_offsets
,
&
dst_offsets
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
(
i8
),
INTENT
(
in
)
::
num_repetitions
INTEGER
,
INTENT
(
in
)
::
src_offsets
(
num_repetitions
)
INTEGER
,
INTENT
(
in
)
::
dst_offsets
(
num_repetitions
)
IF
(
num_repetitions
<
0_c_int
.OR.
&
num_repetitions
>
HUGE
(
1_c_int
))
&
CALL
xt_abort
(
"invalid number of extents"
,
&
__
FILE__
,
&
__
LINE__
)
CALL
xt_dmap_repeat_f
(
&
dmap
,
INT
(
num_repetitions
,
c_int
),
src_offsets
,
dst_offsets
)
END
SUBROUTINE
xt_dmap_repeat_i8_a1d
SUBROUTINE
xt_dmap_reorder
(
dmap
,
reorder_type
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
(
xt_reorder_type_kind
),
INTENT
(
in
)
::
reorder_type
INTERFACE
SUBROUTINE
xt_dmap_reorder_f
(
dmap
,
reorder_type
)
&
BIND
(
C
,
name
=
'xt_dmap_reorder_f'
)
IMPORT
::
xt_dmap
,
c_int
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
(
c_int
),
VALUE
,
INTENT
(
in
)
::
reorder_type
END
SUBROUTINE
xt_dmap_reorder_f
END
INTERFACE
IF
(
reorder_type
<
0_xt_reorder_type_kind
.OR.
&
reorder_type
>
HUGE
(
1_c_int
))
&
CALL
xt_abort
(
"invalid reorder type"
,
&
__
FILE__
,
&
__
LINE__
)
CALL
xt_dmap_reorder_f
(
dmap
,
INT
(
reorder_type
,
c_int
))
END
SUBROUTINE
xt_dmap_reorder
FUNCTION
xt_dmap_generate_redist
(
dmap
,
datatype
)
RESULT
(
redist
)
IMPLICIT
NONE
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap
INTEGER
,
VALUE
,
INTENT
(
in
)
::
datatype
TYPE
(
xt_redist
)
::
redist
INTERFACE
FUNCTION
xt_dmap_generate_redist_f
(
dmap_f
,
datatype
)
&
BIND
(
c
,
name
=
'xt_dmap_generate_redist_f'
)
RESULT
(
redist
)
IMPORT
::
xt_dmap
,
xt_mpi_fint_kind
,
c_ptr
TYPE
(
xt_dmap
),
INTENT
(
in
)
::
dmap_f
INTEGER
(
xt_mpi_fint_kind
),
VALUE
,
INTENT
(
in
)
::
datatype
TYPE
(
c_ptr
)
::
redist
END
FUNCTION
xt_dmap_generate_redist_f
END
INTERFACE
redist
=
xt_redist_c2f
(
xt_dmap_generate_redist_f
(
dmap
,
datatype
))
END
FUNCTION
xt_dmap_generate_redist
FUNCTION
xt_dmap_offset_new
(
xmap
,
src_offsets
,
dst_offsets
)
RESULT
(
dmap
)
IMPLICIT
NONE
TYPE
(
xt_xmap
),
INTENT
(
in
)
::
xmap
INTEGER
,
INTENT
(
in
)
::
src_offsets
(
*
)
INTEGER
,
INTENT
(
in
)
::
dst_offsets
(
*
)
TYPE
(
xt_dmap
)
::
dmap
INTERFACE
FUNCTION
xt_dmap_offset_new_f
(
xmap_f
,
src_offsets
,
dst_offsets
)
&
BIND
(
C
,
name
=
'xt_dmap_offset_new_f'
)
RESULT
(
dmap
)
IMPORT
::
xt_xmap
,
xt_mpi_fint_kind
,
c_ptr
IMPLICIT
NONE
TYPE
(
xt_xmap
),
INTENT
(
in
)
::
xmap_f
INTEGER
(
xt_mpi_fint_kind
),
INTENT
(
in
)
::
src_offsets
(
*
)
INTEGER
(
xt_mpi_fint_kind
),
INTENT
(
in
)
::
dst_offsets
(
*
)
TYPE
(
c_ptr
)
::
dmap
END
FUNCTION
xt_dmap_offset_new_f
END
INTERFACE
dmap
=
xt_dmap_c2f
(&
xt_dmap_offset_new_f
(
xmap
,
src_offsets
,
dst_offsets
))
END
FUNCTION
xt_dmap_offset_new
END
MODULE
xt_dmap_base
!
! Local Variables:
! f90-continuation-indent: 5
! coding: utf-8
! indent-tabs-mode: nil
! show-trailing-whitespace: t
! require-trailing-newline: t
! End:
!
src/yaxt.f90
View file @
a45007b6
...
...
@@ -84,6 +84,10 @@ MODULE yaxt
xt_xmap_iterator_get_num_transfer_pos_ext
USE
xt_xmap_intersection
,
ONLY
:
xt_xmap_intersection_new
,
&
xt_xmap_intersection_ext_new
,
xt_com_list
USE
xt_dmap_base
,
ONLY
:
xt_dmap
,
xt_dmap_c2f
,
xt_dmap_f2c
,
xt_is_null
,
&
xt_dmap_delete
,
xt_dmap_offset_new
,
xt_dmap_generate_redist
,
&
xt_dmap_repeat
,
xt_dmap_reorder
,
xt_reorder_type_kind
,
XT_REORDER_NONE
,
&
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
USE
xt_redist_base
,
ONLY
:
xt_redist
,
xt_redist_c2f
,
xt_redist_f2c
,
&
xt_redist_copy
,
&
xt_redist_delete
,
xt_redist_s_exchange1
,
xt_redist_s_exchange
,
&
...
...
@@ -139,6 +143,9 @@ MODULE yaxt
xt_xmap_iterator_get_num_transfer_pos
,
xt_xmap_iterator_delete
,
&
xt_xmap_iterator_get_transfer_pos_ext
,
&
xt_xmap_iterator_get_num_transfer_pos_ext
,
&
xt_dmap_c2f
,
xt_dmap_f2c
,
xt_dmap_delete
,
xt_reorder_type_kind
,
&
xt_dmap
,
xt_dmap_offset_new
,
xt_dmap_generate_redist
,
xt_dmap_reorder
,
&
xt_dmap_repeat
,
XT_REORDER_NONE
,
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
,
&
xt_redist
,
xt_redist_f2c
,
xt_redist_c2f
,
&
xt_redist_p2p_off_new
,
xt_redist_p2p_new
,
&
xt_redist_p2p_blocks_off_new
,
xt_redist_p2p_blocks_new
,
&
...
...
src/yaxt_f2c.c
View file @
a45007b6
...
...
@@ -66,16 +66,18 @@
#include "xt/xt_mpi.h"
#include "xt/xt_idxlist.h"
#include "xt/xt_idxvec.h"
#include "xt/xt_idxstripes.h"
#include "xt/xt_idxmod.h"
#include "xt/xt_xmap.h"
#include "xt/xt_xmap_intersection.h"
#include "xt/xt_xmap_all2all.h"
#include "xt/xt_xmap_dist_dir.h"
#include "xt/xt_xmap_dist_dir_intercomm.h"
#include "xt/xt_idxstripes.h"
#include "xt/xt_dmap.h"
#include "xt/xt_dmap_offset.h"
#include "xt/xt_redist.h"
#include "xt/xt_redist_p2p.h"
#include "xt/xt_redist_single_array_base.h"
#include "xt/xt_idxmod.h"
#include "xt/xt_redist_collection_static.h"
#include "xt/xt_redist_collection.h"
#include "xt/xt_sort.h"
...
...
@@ -88,6 +90,10 @@ struct xt_xmap_f {
Xt_xmap
cptr
;
};
struct
xt_dmap_f
{
Xt_dmap
cptr
;
};
struct
xt_redist_f
{
Xt_redist
cptr
;
};
...
...
@@ -147,6 +153,11 @@ Xt_idxlist xt_idxlist_f2c(struct xt_idxlist_f *p)
return
p
->
cptr
;
}
Xt_dmap
xt_dmap_f2c
(
struct
xt_dmap_f
*
p
)
{
return
p
->
cptr
;
}
Xt_redist
xt_redist_f2c
(
struct
xt_redist_f
*
p
)
{
return
p
->
cptr
;
...
...
@@ -223,6 +234,33 @@ xt_xmap_dist_dir_intercomm_new_f(struct xt_idxlist_f *src_idxlist_f,
inter_comm_c
,
intra_comm_c
);
}
void
xt_dmap_reorder_f
(
struct
xt_dmap_f
*
dmap_f
,
int
reorder_type
)
{
xt_dmap_reorder
(
dmap_f
->
cptr
,
(
enum
xt_reorder_type
)
reorder_type
);
}
void
xt_dmap_repeat_f
(
struct
xt_dmap_f
*
dmap_f
,
int
num_repetitions
,
MPI_Fint
*
src_displacements
,
MPI_Fint
*
dst_displacements
)
{
assert
(
sizeof
(
MPI_Fint
)
==
sizeof
(
int
));
xt_dmap_repeat
(
dmap_f
->
cptr
,
num_repetitions
,
src_displacements
,
dst_displacements
);
}
void
*
xt_dmap_generate_redist_f
(
struct
xt_dmap_f
*
dmap_f
,
MPI_Fint
datatype_f
)
{
return
xt_dmap_generate_redist
(
dmap_f
->
cptr
,
MPI_Type_f2c
(
datatype_f
));
}
Xt_dmap
xt_dmap_offset_new_f
(
struct
xt_xmap_f
*
xmap_f
,
MPI_Fint
*
src_offsets
,
MPI_Fint
*
dst_offsets
)
{
assert
(
sizeof
(
MPI_Fint
)
==
sizeof
(
int
));
return
xt_dmap_offset_new
(
xmap_f
->
cptr
,
src_offsets
,
dst_offsets
);
}
Xt_redist
xt_redist_p2p_blocks_off_new_f
(
struct
xt_xmap_f
*
xmap_f
,
int
*
src_block_offsets
,
int
*
src_block_sizes
,
...
...
tests/Makefile.am
View file @
a45007b6
...
...
@@ -38,6 +38,7 @@ noinst_PROGRAMS = \
test_mpi_generate_datatype
\
test_mpi_smartdedup
\
test_dmap_parallel
\
test_dmap_parallel_f
\
test_exchanger_parallel
\
test_handles
\
test_idxempty
\
...
...
@@ -138,6 +139,8 @@ FCLINK = $(LIBTOOL) $(AM_V_lt) --tag=FC $(AM_LIBTOOLFLAGS) \
test_exchanger_parallel_SOURCES
=
test_exchanger_parallel.c tests.h
test_dmap_parallel_SOURCES
=
test_dmap_parallel.c tests.h
test_dmap_parallel_f_SOURCES
=
test_dmap_parallel_f.f90
test_dmap_parallel_f_LDADD
=
$(XT_FC_LDADD)
test_idxempty_SOURCES
=
test_idxempty.c tests.h test_idxlist_utils.h
test_idxempty_f_SOURCES
=
test_idxempty_f.f90
test_idxempty_f_LDADD
=
$(XT_FC_LDADD)
...
...
tests/test_dmap_parallel_f.f90
0 → 100644
View file @
a45007b6
!>
!! @file test_dmap_parallel_f.f90
!!
!! @copyright Copyright (C) 2018 Jörg Behrens <behrens@dkrz.de>
!! Moritz Hanke <hanke@dkrz.de>
!! Thomas Jahns <jahns@dkrz.de>
!!
!! @author Jörg Behrens <behrens@dkrz.de>
!! Moritz Hanke <hanke@dkrz.de>
!! Thomas Jahns <jahns@dkrz.de>
!!
!
! Keywords:
! Maintainer: Jörg Behrens <behrens@dkrz.de>
! Moritz Hanke <hanke@dkrz.de>
! Thomas Jahns <jahns@dkrz.de>
! URL: https://doc.redmine.dkrz.de/yaxt/html/
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
#define NUM_RANKS (4)
PROGRAM
test_dmap_parallel_f
USE
mpi
USE
yaxt
,
ONLY
:
xt_initialize
,
xt_finalize
,
&
xt_idxlist
,
xt_idxvec_new
,
xt_idxlist_delete
,
&
xt_xmap
,
xt_xmap_all2all_new
,
xt_xmap_delete
,
&
xt_dmap
,
xt_dmap_offset_new
,
xt_dmap_delete
,
xt_dmap_repeat
,
&
xt_dmap_reorder
,
xt_dmap_generate_redist
,
&
XT_REORDER_NONE
,
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
,
&
xt_redist
,
xt_redist_s_exchange
,
xt_redist_delete
USE
ftest_common
,
ONLY
:
init_mpi
,
finish_mpi
,
test_abort
,
cmp_arrays
USE
test_idxlist_utils
,
ONLY
:
test_err_count
IMPLICIT
NONE
INTEGER
::
comm_size
CHARACTER
(
len
=*
),
PARAMETER
::
filename
=
&
__
FILE__
! init mpi
CALL
init_mpi
CALL
xt_initialize
(
mpi_comm_world
)
IF
(
mpi_size
(
mpi_comm_world
)
/
=
NUM_RANKS
)
&
CALL
test_abort
(
"non-zero error count!"
,
&
filename
,
__
LINE__
)
CALL
test1
()
CALL
xt_finalize
CALL
finish_mpi
CONTAINS
INTEGER
FUNCTION
mpi_rank
(
comm
)
INTEGER
,
INTENT
(
in
)
::
comm
INTEGER
::
ierror
CALL
mpi_comm_rank
(
comm
,
mpi_rank
,
ierror
)
IF
(
ierror
/
=
MPI_SUCCESS
)
CALL
test_abort
(
'mpi_rank: MPI_COMM_RANK failed'
,
&
__
FILE__
,
&
__
LINE__
)
END
FUNCTION
mpi_rank
INTEGER
FUNCTION
mpi_size
(
comm
)
INTEGER
,
INTENT
(
in
)
::
comm
INTEGER
::
ierror
CALL
mpi_comm_size
(
comm
,
mpi_size
,
ierror
)
IF
(
ierror
/
=
MPI_SUCCESS
)
CALL
test_abort
(
'mpi_size: MPI_COMM_SIZE failed'
,
&
__
FILE__
,
&
__
LINE__
)
END
FUNCTION
mpi_size
#define NPROMA (4)
#define NLEV (20)
#define NBLK (6)
SUBROUTINE
test1
()
INTEGER
::
i
,
j
,
k
,
l
,
rank
TYPE
(
xt_idxlist
)
::
src_index_list
,
dst_index_list
TYPE
(
xt_xmap
)
::
xmap
INTEGER
::
src_offsets
(
NPROMA
*
NBLK
)
INTEGER
::
dst_offsets
(
NPROMA
*
NBLK
*
NUM_RANKS
)
INTEGER
::
lev_displacements
(
NLEV
)
INTEGER
::
src_data
(
NPROMA
,
NLEV
,
NBLK
)
INTEGER
::
ref_dst_data
(
NPROMA
,
NLEV
,
NBLK
*
NUM_RANKS
)
INTEGER
::
reorder_type
(
3
)
TYPE
(
xt_dmap
)
::
dmap
TYPE
(
xt_redist
)
::
redist
INTEGER
::
dst_data
(
NPROMA
,
NLEV
,
NBLK
*
NUM_RANKS
)
rank
=
mpi_rank
(
mpi_comm_world
)
src_index_list
=
xt_idxvec_new
((/(
i
+
rank
*
NPROMA
*
NBLK
,
i
=
1
,
NPROMA
*
NBLK
)/))
dst_index_list
=
xt_idxvec_new
((/(
i
,
i
=
1
,
NPROMA
*
NBLK
*
NUM_RANKS
)/))
xmap
=
xt_xmap_all2all_new
(
src_index_list
,
dst_index_list
,
mpi_comm_world
)
k
=
1
DO
i
=
1
,
NBLK
DO
j
=
1
,
NPROMA
src_offsets
(
k
)
=
(
j
-1
)
+
(
i
-1
)
*
NPROMA
*
NLEV
k
=
k
+
1
END
DO
END
DO
k
=
1
DO
i
=
1
,
NBLK
*
NUM_RANKS
DO
j
=
1
,
NPROMA
dst_offsets
(
k
)
=
(
j
-1
)
+
(
i
-1
)
*
NPROMA
*
NLEV
k
=
k
+
1
END
DO
END
DO
lev_displacements
=
(/((
i
-1
)
*
NPROMA
,
i
=
1
,
NLEV
)/)
DO
i
=
0
,
NLEV
-1
DO
j
=
0
,
NBLK
-1
DO
k
=
0
,
NPROMA
-1
src_data
(
k
+1
,
i
+1
,
j
+1
)
=
rank
*
NPROMA
*
NBLK
+
k
+
j
*
NPROMA
+
&
i
*
NUM_RANKS
*
NPROMA
*
NBLK
END
DO
END
DO
END
DO
DO
i
=
0
,
NLEV
-1
DO
j
=
0
,
NBLK
*
NUM_RANKS
-1
DO
k
=
0
,
NPROMA
-1
ref_dst_data
(
k
+1
,
i
+1
,
j
+1
)
=
&
k
+
j
*
NPROMA
+
i
*
NUM_RANKS
*
NPROMA
*
NBLK
END
DO
END
DO
END
DO
reorder_type
=
(/
XT_REORDER_NONE
,
XT_REORDER_SEND_UP
,
XT_REORDER_RECV_UP
/)
DO
i
=
1
,
SIZE
(
reorder_type
)
dmap
=
xt_dmap_offset_new
(
xmap
,
src_offsets
,
dst_offsets
)
CALL
xt_dmap_repeat
(
dmap
,
NLEV
,
lev_displacements
,
lev_displacements
)
CALL
xt_dmap_reorder
(
dmap
,
reorder_type
(
i
))
redist
=
xt_dmap_generate_redist
(
dmap
,
MPI_INTEGER
)
dst_data
=
-1
CALL
xt_redist_s_exchange
(
redist
,
src_data
,
dst_data
)
IF
(
cmp_arrays
(
dst_data
,
ref_dst_data
))
&
CALL
test_abort
(
"error in xt_dmap"
,
filename
,
__
LINE__
)
CALL
xt_redist_delete
(
redist
)
CALL
xt_dmap_delete
(
dmap
)
END
DO