This is the mail archive of the gcc-bugs@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Bug fortran/37644] compiler Segmentation fault



------- Comment #5 from rlnaff at usgs dot gov  2008-11-05 16:08 -------
Subject: Re:  compiler Segmentation fault

Compiled with gfortran 4.3.2


(bash) stoch.pts/10% export 
LAMHF77=/z/stoch/home/rlnaff/usr/local/bin/gfortran4.3.2
(bash) stoch.pts/10% mpif77 -c -fopenmp reorder_parent.f90
reorder_parent.f90:470: internal compiler error: Segmentation fault
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.



kargl at gcc dot gnu dot org wrote:
> ------- Comment #3 from kargl at gcc dot gnu dot org  2008-11-05 04:10 -------
> Can you attach the code instead of embedded in a message?  
>
> It's a PITA to strip out HTML from your code when I save it as a file.
>
>
>   

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 (p<no_partitions) then
          C1=n0; C2=n0; C3=n0
          ! xxx ii_1=1; ii_2=1; ii_1=1; CC_1=n0; CC_2=n0; CC_3=n0
       endif
    enddo ! end outer partition loop
!$OMP END DO
!$OMP END PARALLEL 
    nullify (R_point)
    ! ...
  contains
    ! ...
    subroutine insert_coef(C11,C22,C33,i11,i22,i33,node)
      ! ...
      ! ... Argument list
      ! ...
      real(kind=kv), intent(in) :: C11,C22,C33
      integer, intent(in) :: i11,i22,i33
      integer, intent(in) :: node
      ! ......................................................
      ! ... 
      if (dim>2) 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


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]