From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 32119 invoked by alias); 29 Sep 2008 13:56:24 -0000 Received: (qmail 30021 invoked by alias); 29 Sep 2008 13:54:57 -0000 Date: Mon, 29 Sep 2008 13:56:00 -0000 Message-ID: <20080929135457.30020.qmail@sourceware.org> X-Bugzilla-Reason: CC References: Subject: [Bug fortran/37644] compiler Segmentation fault In-Reply-To: Reply-To: gcc-bugzilla@gcc.gnu.org To: gcc-bugs@gcc.gnu.org From: "rlnaff at usgs dot gov" Mailing-List: contact gcc-bugs-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-bugs-owner@gcc.gnu.org X-SW-Source: 2008-09/txt/msg02935.txt.bz2 ------- Comment #2 from rlnaff at usgs dot gov 2008-09-29 13:54 ------- Subject: Re: compiler Segmentation fault This was an experiment on the combined usage of Open MP and MPI, and may not be feasible. However, that the compiler would simply fail... R. Naff pinskia at gcc dot gnu dot org wrote: > ------- Comment #1 from pinskia at gcc dot gnu dot org 2008-09-28 19:57 ------- > We need the source to figure out what is going wrong here. > > > module common_parameters implicit none ! OMPI? include '/usr/include/mpif.h' ! include 'mpif.h' ! ... kv: precision of variables used in assembly integer, parameter :: kv=selected_real_kind(p=10) ! ... common numbers real(kind=kv), parameter :: n0=0.0_kv, n1=1.0_kv, n2=2.0_kv, n3=3.0_kv, & n4=4.0_kv, n5=5.0_kv, n6=6.0_kv, n7=7.0_kv, n8=8.0_kv, n9=9.0_kv, & n10=10.0_kv, n100=100.0_kv ! ... common fractions real(kind=kv), parameter :: f2=0.5_kv, f3=n1/n3, f4=0.25_kv, f5=0.2_kv, & f6=n1/n6, f7=n1/n7, f8=0.125_kv, f9=n1/n9, f10=0.1_kv ! ... machine smallest number real(kind=kv), parameter :: machine_epsilon=epsilon(n0) real(kind=kv), parameter :: small=n100*machine_epsilon real(kind=kv), save :: MZ=tiny(n0) ! ... interim print character(len=32) :: file_name integer :: interim_print, data_print end module common_parameters ! ... File shared_common_parent.f90 ! ... ! ... Version last modified: R.L. Naff, 07/06 ! ... Purpose: Allow for the transfer of information between modules ! ... and subroutines of "parent" type. ! ... ! ... Utilization: use "module name" ! ... ! ... Modules herein: ! ... common_input_types_parent ! ... common_partition_types_parent ! ... common_MPI_types_parent ! ... module common_input_types_parent use common_parameters implicit none integer :: n_x, n_y, n_z end module common_input_types_parent module common_partition_types_parent use common_parameters implicit none integer, save :: max_part, npx, npy, npz integer, save :: ind_rot_rn, dim, no_rows integer, save :: tot_variables integer, save :: no_partitions, red_count, max_C integer, save :: red_part_count, red_node_count, black_node_count integer, save :: max_nodes_A, max_nx, max_ny, max_nz ! ... arrays integer, dimension(:), allocatable :: perm_p, inv_perm_p integer, dimension(:), allocatable :: part_end integer, dimension(:), allocatable :: perm end module common_partition_types_parent module common_reorder_types_parent use common_parameters implicit none integer, dimension(:), allocatable, target :: ii_1, ii_2, ii_3 real(kind=kv), dimension(:), allocatable, target :: C1, C2, C3, & CC_1, CC_2, CC_3, coef end module common_reorder_types_parent module common_MPI_types_parent integer :: pc_intracomm, pc_intra_root end module common_MPI_types_parent module reorder_parent ! ... Version last modified: R.L. Naff, 02/07 ! ... Purpose: reorder stiffness coefficients into partitions and ! ... send coefficients to children (slaves). ! ... ! ... Subroutines herein: ! ... subroutine AC_reorder ! ... Called from subroutine MS_PCG_solve, module MS_PCG_parent ! ... Sends or BCasts to Child: coef, C1, C2, C3, ! ... CC_1, CC_2, CC_3 (surrogates for hcoef, C_x, C_y, C_z ! ... and part_con arrays). ! ... ! ... use omp_lib use common_parameters use common_input_types_parent ! ... n_x, n_y, n_z use common_partition_types_parent use common_reorder_types_parent use common_MPI_types_parent !tmp use utilities_parent !tmp use error_handler ! ... pointer arrays holding incoming coefficients real, save, pointer, dimension(:) :: Cii, Cjj, Ckk, hcoef ! ... Arrays pointed in MS_PCG_solve ! ... contains subroutine AC_reorder(i_bound, ib0_count) ! ... Based on domain partitioning, rearrange coefficients and ! ... assign to a process. ! ... ! ... Argument list ! ... integer, intent(out) :: ib0_count integer, dimension(:), intent(in) :: i_bound ! ... ! ... local variables ! ... integer :: p, i, j, k, ii, jj, kk, i_org, xyz_loc integer :: i_1, i_2, i_3, np1, np2, np3 integer :: d_1s, d_2s, d_3s, i_range=range(n1) integer :: n_1, n_2, n_3, d_1, d_2, d_3 integer :: node, row_ct, level_ct, A_nodes integer :: pn_count, ls1, ls2, ls3, e_1, e_2, e_3 integer :: ierr, error, tag_out, a_size integer :: i11, i22, i33, int_real_type integer, dimension(1:3) :: C_count integer, pointer, dimension(:) :: I_point real(kind=kv) :: C11, C22, C33, t_num real :: one=1.0, neg_one=-1.0 real(kind=kv), pointer, dimension(:) :: R_point character(len=64) :: err_loc_message ! ........................................................................ ! ... allocate work space error=0; t_num=n10**(-i_range/2) nullify (R_point) ! ... call rot_rn(1, n_x, n_x*n_y, e_1, e_2, e_3) ! ... call rot_rn(n_x, n_y, n_z, n_1, n_2, n_3) call rot_rn(npx, npy, npz, np1, np2, np3) d_1s=nint(real(n_1)/np1) d_2s=nint(real(n_2)/np2) d_3s=nint(real(n_3)/np3) ! ... ! ... main partitions ! ... pn_count=0; ib0_count=0 call OMP_SET_NUM_THREADS(4) !$OMP PARALLEL DEFAULT(private) SHARED(no_partitions, ind_rot_rn) & !$OMP SHARED(npx, npy, npz, np1, np2, np3) & !$OMP SHARED(n_1, n_2, n_3, e_1, e_2, e_3, d_1s, d_2s, d_3s) & !$OMP SHARED(inv_perm_p, perm, i_bound, Cii, Cjj, Ckk, hcoef) !$OMP DO do p=1, no_partitions C_count=0 ! ... (ii, jj, kk): regular, x first z last, partition numbering xyz_loc=inv_perm_p(p) kk=(xyz_loc-1)/(npx*npy)+1 jj=(xyz_loc-(kk-1)*npx*npy-1)/npx+1 ii=xyz_loc-(kk-1)*npx*npy-(jj-1)*npx call rot_rn(ii, jj, kk, i_1, i_2, i_3) ! ... d_1=d_1s if (i_1==np1) then d_1=n_1-d_1s*(np1-1) C_count(1)=-1 endif d_2=d_2s if (i_2==np2) then d_2=n_2-d_2s*(np2-1) C_count(2)=-1 endif d_3=d_3s if (i_3==np3) then d_3=n_3-d_3s*(np3-1) C_count(3)=-1 endif ! ... do k=1, d_3 level_ct=d_1*d_2*(k-1) ls3=1 if (k==d_3)then if (i_3==np3) then ! ... external boundary ls3=0 else ! ... internal boundary ls3=2 endif endif do j=1, d_2 row_ct=d_1*(j-1) ls2=1 if (j==d_2) then if (i_2==np2) then ! ... external boundary ls2=0 else ! ... internal boundary ls2=2 endif endif do i=1, d_1 ls1=1 if (i==d_1) then if (i_1==np1) then ! ... external boundary ls1=0 else ! ... internal boundary ls1=2 endif endif node=level_ct+row_ct+i i_org=perm(node+pn_count) ! ... Assign higher precision to coef coef(node)=hcoef(i_org) C11=n0; C22=n0; C33=n0 ! ... Assign higher precision to C11, C22 and C33 ! ... Note: all coefficients on external boundies ! ... assigned null value. if (i_bound(i_org)>0) then if (ls1>0) then if (i_bound(i_org+e_1)/=0) C11=sign(Cii(i_org),one) endif if (ls2>0) then if (i_bound(i_org+e_2)/=0) C22=sign(Cjj(i_org),one) endif if (ls3>0) then if (i_bound(i_org+e_3)/=0) C33=sign(Ckk(i_org),one) endif elseif (i_bound(i_org)==0) then ib0_count=ib0_count+1 else ! ... assign constant-value cells a negative value if (ls1>0) then if (i_bound(i_org+e_1)/=0) C11=sign(Cii(i_org),neg_one) endif if (ls2>0) then if (i_bound(i_org+e_2)/=0) C22=sign(Cjj(i_org),neg_one) endif if (ls3>0) then if (i_bound(i_org+e_3)/=0) C33=sign(Ckk(i_org),neg_one) endif if (C11==n0.and.C22==n0.and.C33==n0) then ! ... If no nonzero coefficients present, then assign ! ... C11 a very small negative number. C11=-t_num; ls1=1 endif endif ! ... Assign values to internal-boundary indicator array. ! ... Value assigned indicates node type across boundary. i11=1; i22=1; i33=1 if (ls1==2) then if (i_bound(i_org+e_1)==0) then i11=0 elseif (i_bound(i_org+e_1)<0) then i11=-1 endif endif if (ls2==2) then if (i_bound(i_org+e_2)==0) then i22=0 elseif (i_bound(i_org+e_2)<0) then i22=-1 endif endif if (ls3==2) then if (i_bound(i_org+e_3)==0) then i33=0 elseif (i_bound(i_org+e_3)<0) then i33=-1 endif endif ! ... Insert final coefficients into C1, C2 and C_ arrays ! ... or into connector coefficient arrays (lsx=2). call insert_coef(C11, C22, C33, i11, i22, i33, node) ! ... enddo enddo enddo ! ... A_nodes=d_1*d_2*d_3 pn_count=pn_count+A_nodes ! xxx if (C_count(1)/=d_2*d_3) print*,'C_count(1)=',C_count(1), & ! xxx ' face value=',d_2*d_3 ! xxx if (C_count(2)/=d_1*d_3) print*,'C_count(2)=',C_count(2), & ! xxx ' face value=',d_1*d_3 ! xxx if (C_count(3)/=d_1*d_2) print*,'C_count(3)=',C_count(3), & ! xxx ' face value=',d_1*d_2 ! ... ! ... Send A partitions to spawned processes ! ... Received in subroutine coef_recv, module PCG_solve_child ! ... tag_out=1211 R_point=>coef(1:A_nodes) call MPI_SSEND(R_point, A_nodes, MPI_DOUBLE_PRECISION, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr) tag_out=1212 R_point=>C1(1:A_nodes) call MPI_SSEND(R_point, A_nodes, MPI_DOUBLE_PRECISION, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr) C1=n0 if (dim>1) then tag_out=1213 R_point=>C2(1:A_nodes) call MPI_SSEND(R_point, A_nodes, MPI_DOUBLE_PRECISION, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr) C2=n0 if (dim>2) then tag_out=1214 R_point=>C3(1:A_nodes) call MPI_SSEND(R_point, A_nodes, MPI_DOUBLE_PRECISION, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr) C3=n0 endif endif ! ... ! ... Send connectors to partitions ! ... Received in subroutine coef_recv, module PCG_solve_child ! ... if (C_count(1)>0) then err_loc_message='reorder_parent AC_reorder MPI_SEND 1' R_point=>CC_1(1:C_count(1)) I_point=>ii_1(1:C_count(1)) ! ... ! ??? 02/14/07 ! ??? The following MPI structure is malfunctioning for unknown ! ??? reasons; using MPI sends 12150 and 12151 instead. ! ??? 04/04/07 now functioning tag_out=1215 int_real_type=MPI_struct_int_real_array(I_point,R_point) call MPI_SSEND(I_point, 1, int_real_type, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr, err_loc_message) call MPI_TYPE_FREE(int_real_type,ierr) ! ... ! xxx tag_out=12150 ! xxx call MPI_SEND(I_point, C_count(1), MPI_INTEGER, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! xxx tag_out=12151 ! xxx call MPI_SEND(R_point, C_count(1), MPI_DOUBLE_PRECISION, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! ... CC_1=n0; II_1=0 endif ! ... if (C_count(2)>0) then err_loc_message='reorder_parent AC_reorder MPI_SEND 2' R_point=>CC_2(1:C_count(2)) I_point=>ii_2(1:C_count(2)) ! ... ! ??? 02/14/07 ! ??? The following MPI structure is malfunctioning for unknown ! ??? reasons; using MPI sends 12160 and 12161 instead. ! ??? 04/04/07 now functioning int_real_type=MPI_struct_int_real_array(I_point,R_point) tag_out=1216 call MPI_SSEND(I_point, 1, int_real_type, & p, tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr, err_loc_message) call MPI_TYPE_FREE(int_real_type,ierr) ! ... ! xxx tag_out=12160 ! xxx call MPI_SEND(I_point, C_count(2), MPI_INTEGER, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! xxx tag_out=12161 ! xxx call MPI_SEND(R_point, C_count(2), MPI_DOUBLE_PRECISION, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! ... CC_2=n0; II_2=0 endif ! ... if (C_count(3)>0) then err_loc_message='reorder_parent AC_reorder MPI_SEND 3' R_point=>CC_3(1:C_count(3)) I_point=>ii_3(1:C_count(3)) ! ... ! ??? 02/14/07 ! ??? The following MPI structure is malfunctioning for unknown ! ??? reasons; using MPI sends 12170 and 12171 instead. ! ??? 04/04/07 now functioning tag_out=1217 int_real_type=MPI_struct_int_real_array(I_point,R_point) call MPI_SSEND(I_point, 1, int_real_type, p, & tag_out, pc_intracomm, ierr) call error_class(pc_intracomm, ierr, err_loc_message) call MPI_TYPE_FREE(int_real_type,ierr) ! ... ! xxx tag_out=12170 ! xxx call MPI_SEND(I_point, C_count(3), MPI_INTEGER, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! xxx tag_out=12171 ! xxx call MPI_SEND(R_point, C_count(3), MPI_DOUBLE_PRECISION, p, & ! xxx tag_out, pc_intracomm, ierr) ! xxx call error_class(pc_intracomm, ierr, err_loc_message) ! ... CC_3=n0; II_3=0 endif nullify (I_point, R_point) ! ... if (p2) then ! ... 3-D if (ls1==1) then C1(node)=C11 elseif (ls1==2) then C_count(1)=C_count(1)+1 CC_1(C_count(1))=C11 ii_1(C_count(1))=i11 endif if (ls2==1) then C2(node)=C22 elseif (ls2==2) then C_count(2)=C_count(2)+1 CC_2(C_count(2))=C22 ii_2(C_count(2))=i22 endif if (ls3==1) then C3(node)=C33 elseif (ls3==2) then C_count(3)=C_count(3)+1 CC_3(C_count(3))=C33 ii_3(C_count(3))=i33 endif elseif (dim>1) then ! ... 2-D slice if (ls1==1) then C1(node)=C11 elseif (ls1==2) then C_count(1)=C_count(1)+1 CC_1(C_count(1))=C11 ii_1(C_count(1))=i11 endif if (ls2==1) then C2(node)=C22 elseif (ls2==2) then C_count(2)=C_count(2)+1 CC_2(C_count(2))=C22 ii_2(C_count(2))=i22 endif else ! ... 1-D if (ls1==1) then C1(node)=C11 elseif (ls1==2) then C_count(1)=C_count(1)+1 CC_1(C_count(1))=C11 ii_1(C_count(1))=i11 endif endif ! ... end subroutine insert_coef ! ... end subroutine AC_reorder function MPI_struct_int_real_array(indx,value) result(type_int_real) ! ... Purpose: Build an MPI structure consisting of an integer array and ! ... a double precision real array. ! ... Explicit interface required: assumed-shape arrays INDX and VALUE. ! ... ! ... argument list ! ... integer, dimension(:) :: indx real(kind=kv), dimension(:) :: value ! ... ! ... result ! ... integer :: type_int_real ! ... ! ... local variables ! ... integer, dimension(1:2) :: blks, types, displs integer :: ierr, i_size, v_size, start_address, address character(len=64) :: err_loc_message= & 'PCG_solve_child MPI_struct_int_real_array MPI_TYPE_COMMIT 1' ! ....................................................................... type_int_real=0 i_size=size(indx); v_size=size(value) blks=(/i_size, v_size/) types=(/MPI_INTEGER, MPI_DOUBLE_PRECISION/) displs(1)=0 call MPI_ADDRESS(indx(1), start_address, ierr) call MPI_ADDRESS(value(1), address, ierr) displs(2)=address-start_address call MPI_TYPE_STRUCT(2, blks, displs, types, type_int_real, ierr) call MPI_TYPE_COMMIT(type_int_real,ierr) call error_class(pc_intracomm, ierr, err_loc_message) ! ... end function MPI_struct_int_real_array end module reorder_parent -- http://gcc.gnu.org/bugzilla/show_bug.cgi?id=37644