fstr_param_setup.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
module m_fstr_param_setup
  use m_fstr
  use hecmw_setup_util, only &
    : node_grp_name_to_id_ex
  use fstr_setup_util, only &
    : fstr_param_pack &
    , fstr_card_slot &
    , fstr_ctrl_err_stop &
    , append_new_amplitude
  use fstr_ctrl_common
  use fstr_ctrl_static
  use mcontactparam
  use m_utilities
  use fstr_ctrl_util_f
  implicit none
 
contains
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_version( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_data_ex( ctrl, 1, 'i ', p%STATE%version )
 
  end subroutine fstr_setup_version
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_solution( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_solution( ctrl, p%PARAM%solution_type, p%PARAM%nlgeom )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_solution
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_nonlinear_solver( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_nonlinear_solver( ctrl, p%PARAM%nlsolver_method )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_nonlinear_solver
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_solver( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    if( slot%first > 1 ) then
      write(ilog,*) '### Error : !SOLVER exists twice in FSTR control file.'
      stop hecmw_exit_input
    endif
 
    !   nier       => svIarray(1)
    !   method     => svIarray(2)
    !   precond    => svIarray(3)
    !   nset       => svIarray(4)
    !   iterpremax => svIarray(5)
    !   nrest      => svIarray(6)
    !   scaling    => svIarray(7)
    !   iterlog    => svIarray(21)
    !   timelog    => svIarray(22)
    !   steplog    => svIarray(23)
    !   loglevel   => svIarray(24)
    !   dumptype   => svIarray(31)
    !   dumpexit   => svIarray(32)
    !   usejad     => svIarray(33)
    !   ncolor_in  => svIarray(34)
    !   mpc_method => svIarray(13)
    !   estcond    => svIarray(14)
    !   contact_elim=> svIarray(15)
    !   recompute_residual => svIarray(16)
    !   method2    => svIarray(8)
    !   recyclepre => svIarray(35)
    !   matvec_impl=> svIarray(36)
    !   precond_impl=> svIarray(37)
    !   solver_opt => svIarray(41:50)
    !   nBFGS      => svIarray(60)
 
    !   resid      => svRarray(1)
    !   sigma_diag => svRarray(2)
    !   omega      => svRarray(3)
    !   thresh     => svRarray(4)
    !   filter     => svRarray(5)
    !   solver_ropt=> svRarray(41:50)
 
    rcode = fstr_ctrl_get_solver( ctrl,                      &
      p%MAT%Iarray(2), p%MAT%Iarray(3), p%MAT%Iarray(4), &
      p%MAT%Iarray(21), p%MAT%Iarray(22), p%MAT%Iarray(23), &
      p%MAT%Iarray(1), p%MAT%Iarray(5), p%MAT%Iarray(6), p%MAT%Iarray(60), p%MAT%Iarray(7), &
      p%MAT%Iarray(31), p%MAT%Iarray(32), p%MAT%Iarray(33), p%MAT%Iarray(34), &
      p%MAT%Iarray(13), p%MAT%Iarray(14), p%MAT%Iarray(8), &
      p%MAT%Iarray(35), p%MAT%Iarray(41:50), p%MAT%Iarray(15), &
      p%MAT%Rarray(1), p%MAT%Rarray(2), p%MAT%Rarray(3), &
      p%MAT%Rarray(4), p%MAT%Rarray(5), p%MAT%Rarray(41:50), p%MAT%Iarray(24), &
      p%MAT%Iarray(36), p%MAT%Iarray(37), p%MAT%Iarray(16) )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
    if( p%MAT%Iarray(2) <= 100 ) then
      p%MAT%Iarray(99) = 1  ! indirect method
    else
      p%MAT%Iarray(99) = p%MAT%Iarray(2)-99 !2  ! direct method
    end if
 
  end subroutine fstr_setup_solver
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  subroutine fstr_setup_orientation( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    if( fstr_get_orientation( ctrl, p%MESH, g_localcoordsys(slot%first) )/=0 ) then
      write(*,*) '### Error: Fail in read in ORIENTATION definition : ', slot%first
      write(ilog,*) '### Error: Fail in read in ORIENTATION definition : ', slot%first
      stop hecmw_exit_input
    endif
  end subroutine fstr_setup_orientation
 
  integer function fstr_get_orientation( ctrl, hecMESH, coordsys )
    use hecmw_setup_util, only: node_global_to_local
    implicit none
    integer(kind=kint)         :: ctrl
    type( hecmwst_local_mesh ) :: hecmesh
    type( tlocalcoordsys )     :: coordsys
 
    character(len=HECMW_NAME_LEN) :: grp_id_name(1)
 
    integer :: nid, dtype
    character(len=HECMW_NAME_LEN) :: data_fmt
    real(kind=kreal) :: fdum, xyza(3), xyzb(3), xyzc(3), ff1(3), ff2(3), ff3(3)
 
    fstr_get_orientation = -1
 
    nid = 1
    coordsys%sys_type = 10
 
    nid = 1
    data_fmt = 'COORDINATES,NODES,LOCAL_NODES '
    if( fstr_ctrl_get_param_ex( ctrl, 'DEFINITION ', data_fmt, 0, 'P', nid )/=0 ) return
    dtype = nid-1
    coordsys%sys_type = coordsys%sys_type + dtype
 
    if( fstr_ctrl_get_param_ex( ctrl, 'NAME ',  '# ',  1, 'S', grp_id_name(1) )/= 0) return
    coordsys%sys_name = grp_id_name(1)
 
    if( dtype==0 ) then
      data_fmt = "RRRRRRrrr "
      xyzc(:) = 0.d0
      if( fstr_ctrl_get_data_ex( ctrl, 1, data_fmt, xyza(1), xyza(2),  &
        xyza(3), xyzb(1), xyzb(2), xyzb(3), xyzc(1), xyzc(2), xyzc(3) )/=0 ) return
      if( coordsys%sys_type==10 ) then
        ff1 = xyza-xyzc
        fdum = dsqrt( dot_product(ff1, ff1) )
        if( fdum==0.d0 ) return
        ff1 = ff1/fdum
        ff2 = xyzb-xyzc
        call cross_product(ff1,ff2,ff3)
        coordsys%CoordSys(1,:) = ff1
 
        fdum = dsqrt( dot_product(ff3, ff3) )
        if( fdum==0.d0 ) return
        coordsys%CoordSys(3,:) = ff3/fdum
 
        call cross_product(coordsys%CoordSys(3,:), coordsys%CoordSys(1,:), coordsys%CoordSys(2,:) )
      else
        coordsys%CoordSys(1,:) = xyza
        coordsys%CoordSys(2,:) = xyzb
      endif
 
    else
      coordsys%node_ID(3) = 0   ! global origin
      data_fmt = "IIi "
      if( fstr_ctrl_get_data_ex( ctrl, 1, data_fmt, coordsys%node_ID(1),  &
        coordsys%node_ID(2), coordsys%node_ID(3) )/=0 ) return
      ! DEFINITION=LOCAL_NODES: three local node numbers (1..number of nodes of
      ! the element) defining the coordinate system of each element. All three
      ! are mandatory here, unlike the third node of DEFINITION=NODES.
      if( dtype==2 ) then
        if( maxval(coordsys%node_ID(1:3)) > 10 .or. minval(coordsys%node_ID(1:3)) < 1 ) then
          write(*,*) "!ORIENTATION, DEFINITION=LOCAL_NODES needs three local node numbers (1-10)!"
          write(idbg,*) "!ORIENTATION, DEFINITION=LOCAL_NODES needs three local node numbers (1-10)!"
          return
        endif
        fstr_get_orientation = 0
        return
      endif
      if( coordsys%node_ID(3) == 0 ) then
        nid = node_global_to_local( hecmesh, coordsys%node_ID(1:2), 2 )
        if( nid/=0 .and. nid/=2 ) then
          write(*,*) "We cannot define coordinate system using nodes in other CPU!"
          write(idbg,*) "We cannot define coordinate system using nodes in other CPU!"
          return
        endif
      else
        nid = node_global_to_local( hecmesh, coordsys%node_ID, 3 )
        if( nid/=0 .and. nid/=3 ) then
          write(*,*) "We cannot define coordinate system using nodes in other CPU!"
          write(idbg,*) "We cannot define coordinate system using nodes in other CPU!"
          return
        endif
      endif
    endif
 
    fstr_get_orientation = 0
  end function fstr_get_orientation
 
  subroutine fstr_setup_initial_condition( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    if( fstr_get_initial_condition( ctrl, g_initialcnd(slot%first), p%MESH )/=0 ) then
       write(*,*) '### Error: Fail in read in INITIAL CONDITION definition : ' ,slot%first
       write(ilog,*) '### Error: Fail in read in INITIAL CONDITION definition : ', slot%first
       stop hecmw_exit_input
    endif
  end subroutine fstr_setup_initial_condition
 
  integer(kind=kint) function fstr_get_initial_condition( ctrl, cond, hecMESH )
    implicit none
    integer(kind=kint)        :: ctrl
    type( tinitialcondition ) :: cond
    type(hecmwst_local_mesh)  :: hecmesh
    integer, pointer          :: grp_id(:), dof(:)
    real(kind=kreal), pointer :: temp(:)
    character(len=HECMW_NAME_LEN), pointer :: grp_id_name(:)
    character(len=HECMW_NAME_LEN) :: data_fmt, ss
    integer :: i,j,n, is, ie, gid, nid, rcode
 
    fstr_get_initial_condition = -1
 
    ss = 'TEMPERATURE,VELOCITY,ACCELERATION '
    rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', ss, 1, 'P', nid )
    if( nid==1 ) then
      cond%cond_name = "temperature"
      allocate( cond%intval(hecmesh%n_node) )
      allocate( cond%realval(hecmesh%n_node) )
    elseif( nid==2 ) then
      cond%cond_name = "velocity"
      allocate( cond%intval(hecmesh%n_node) )
      allocate( cond%realval(hecmesh%n_node) )
    elseif( nid==3 ) then
      cond%cond_name = "acceleration"
      allocate( cond%intval(hecmesh%n_node) )
      allocate( cond%realval(hecmesh%n_node) )
    else
      return
    endif
 
    cond%intval = -1
    cond%realval = 0.d0
 
    n = fstr_ctrl_get_data_line_n( ctrl )
    if( n<=0 ) return
    allocate( temp(n), grp_id_name(n), grp_id(n), dof(n) )
    dof = 0
    write(ss,*)  hecmw_name_len
    if( nid==1 ) then
      write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'R '
      fstr_get_initial_condition = &
            fstr_ctrl_get_data_array_ex( ctrl, data_fmt, grp_id_name, temp )
    else
        write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'IR '
        fstr_get_initial_condition = &
            fstr_ctrl_get_data_array_ex( ctrl, data_fmt, grp_id_name, dof, temp )
    endif
 
    if( fstr_get_initial_condition /= 0 ) then
        if( associated(grp_id) )    deallocate( grp_id )
        if( associated(temp) )    deallocate( temp )
        if( associated(dof) )       deallocate( dof )
        if( associated(grp_id_name) )    deallocate( grp_id_name )
        return
    end if
 
    call node_grp_name_to_id_ex( hecmesh, '!INITIAL CONDITION', n, grp_id_name, grp_id )
    do i=1,n
      gid = grp_id(i)
      is = hecmesh%node_group%grp_index(gid-1) + 1
      ie = hecmesh%node_group%grp_index(gid  )
      do j=is, ie
        nid = hecmesh%node_group%grp_item(j)
        cond%realval(nid) = temp(i)
        cond%intval(nid) = dof(i)
      enddo
    enddo
 
    if( associated(grp_id) )    deallocate( grp_id )
    if( associated(temp) )      deallocate( temp )
    if( associated(dof) )       deallocate( dof )
    if( associated(grp_id_name) )    deallocate( grp_id_name )
  end function fstr_get_initial_condition
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_write( ctrl, counter, P )
    implicit none
    integer(kind=kint) :: ctrl
    integer(kind=kint) :: counter
    type(fstr_param_pack) :: P
    integer(kind=kint) :: res, visual, neutral
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_write( ctrl, res, visual, neutral )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
    if( res == 1 ) p%PARAM%fg_result = 1
    if( visual == 1 ) p%PARAM%fg_visual = 1
    if( neutral == 1 ) p%PARAM%fg_neutral = 1
 
  end subroutine fstr_setup_write
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_echo( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_echo( ctrl,        &
      p%PARAM%fg_echo )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_echo
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_restart( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode, nout
    nout = 0
    rcode = fstr_ctrl_get_param_ex( ctrl, 'FREQUENCY ', '# ', 0, 'I', nout )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
    rcode = fstr_ctrl_get_param_ex( ctrl, 'VERSION ', '# ', 0, 'I', p%PARAM%restart_version )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
    p%SOLID%restart_nout= nout
    p%DYN%restart_nout= nout
    p%HEAT%restart_nout= nout
 
  end subroutine fstr_setup_restart
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_amplitude( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
    real(kind=kreal), pointer :: val(:), table(:)
    character(len=HECMW_NAME_LEN) :: name
    integer :: nline, n, type_def, type_time, type_val, rcode
 
    nline = fstr_ctrl_get_data_line_n( ctrl )
    if( nline<=0 ) return
    allocate( val(nline*4) )
    allocate( table(nline*4) )
    rcode = fstr_ctrl_get_amplitude( ctrl, nline, name, type_def, type_time, type_val, &
        n, val, table )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
    call append_new_amplitude( p%MESH%amp, name, type_def, type_time, type_val, n, val, table )
 
    if( associated(val) ) deallocate( val )
    if( associated(table) ) deallocate( table )
  end subroutine fstr_setup_amplitude
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_reftemp( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
    rcode = fstr_ctrl_get_reftemp( ctrl, p%PARAM%ref_temp )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_reftemp
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_mpc( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
    !        integer(kind=kint) :: type
    !        integer(kind=kint),pointer :: node1_ptr(:)
    !        integer(kind=kint),pointer :: node2_ptr(:)
    !        integer(kind=kint),pointer :: dof_ptr(:)
    !        integer(kind=kint) :: n, old_size, new_size
    !
    !        rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', 'RIGID ', 1, 'P', type )
    !        if( rcode < 0 ) call fstr_ctrl_err_stop
    !
    !        n = fstr_ctrl_get_data_line_n( ctrl )
    !        if( n == 0 ) return
    !        old_size = P%MPC_RD%nmpc
    !        new_size = old_size + n
    !        P%MPC_RD%nmpc = new_size
    !
    !        call hecmw_expand_integer_array ( P%MPC_RD%node1,  old_size, new_size )
    !        call hecmw_expand_integer_array ( P%MPC_RD%node2,  old_size, new_size )
    !        call hecmw_expand_integer_array ( P%MPC_RD%dof,    old_size, new_size )
    !
    !        node1_ptr => P%MPC_RD%node1(old_size+1:)
    !        node2_ptr => P%MPC_RD%node2(old_size+1:)
    !        dof_ptr   => P%MPC_RD%dof(old_size+1:)
    !
    !        rcode = fstr_ctrl_get_MPC( ctrl, type, node1_ptr, node2_ptr, dof_ptr )
    !        if( rcode /= 0 ) call fstr_ctrl_err_stop
    !
    !        if( node_global_to_local( P%MESH, node1_ptr, n ) /= n ) then
    !                call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' )
    !        endif
    !        if( node_global_to_local( P%MESH, node2_ptr, n ) /= n ) then
    !                call fstr_setup_util_err_stop( '### Error : not exist node (!MPC)' )
    !        endif
 
    !   penalty => svRarray(11)
    rcode = fstr_ctrl_get_mpc( ctrl, p%MAT%Rarray(11))
    if( rcode /= 0) call fstr_ctrl_err_stop
  end subroutine fstr_setup_mpc
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_contactalgo( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode
 
 
    rcode = fstr_ctrl_get_contactalgo( ctrl, p%PARAM%contact_algo, p%PARAM%augiter, &
      p%PARAM%fric_cone_follow, p%PARAM%eps_fric_band )
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_contactalgo
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
 
  subroutine fstr_setup_output_sstype( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    integer(kind=kint) :: rcode, nid
    character(len=HECMW_NAME_LEN) :: data_fmt
 
    data_fmt = 'SOLUTION,MATERIAL '
    rcode = fstr_ctrl_get_param_ex( ctrl, 'TYPE ', data_fmt, 0, 'P', nid )
    opsstype = nid
    if( rcode /= 0 ) call fstr_ctrl_err_stop
 
  end subroutine fstr_setup_output_sstype
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_autoinc_param( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_param), pointer :: fstrPARAM
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    fstrparam => p%PARAM
 
    if( fstr_get_autoinc( ctrl, fstrparam%ainc(slot%first) ) /=0 ) then
      write(*,*) '### Error: Fail in read in AUTOINC_PARAM definition : ' , slot%first
      write(ilog,*) '### Error: Fail in read in AUTOINC_PARAM definition : ', slot%first
      stop hecmw_exit_input
    endif
  end subroutine fstr_setup_autoinc_param
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_converg_param( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_param), pointer :: fstrPARAM
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    fstrparam => p%PARAM
 
    if( fstr_ctrl_get_convergparam( ctrl, fstrparam%cnvparam(slot%first) ) /=0 ) then
      write(*,*) '### Error: Fail in read in CONVERG_PARAM definition : ' , slot%first
      write(ilog,*) '### Error: Fail in read in CONVERG_PARAM definition : ', slot%first
      stop hecmw_exit_input
    endif
  end subroutine fstr_setup_converg_param
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_time_points( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_param), pointer :: fstrPARAM
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    fstrparam => p%PARAM
 
    if( fstr_ctrl_get_timepoints( ctrl, fstrparam%timepoints(slot%first) )/=0 ) then
      write(*,*) '### Error: Fail in read in TIME_POINTS definition : ' , slot%first
      write(ilog,*) '### Error: Fail in read in TIME_POINTS definition : ', slot%first
      stop hecmw_exit_input
    endif
  end subroutine fstr_setup_time_points
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_contact_param( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_param), pointer :: fstrPARAM
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    fstrparam => p%PARAM
 
    if( fstr_ctrl_get_contactparam( ctrl, fstrparam%contactparam(slot%first) ) /=0 ) then
      write(*,*) '### Error: Fail in read in CONTACT_PARAM definition : ' , slot%first
      write(ilog,*) '### Error: Fail in read in CONTACT_PARAM definition : ', slot%first
      stop hecmw_exit_input
    endif
  end subroutine fstr_setup_contact_param
 
  !-----------------------------------------------------------------------------!
  !-----------------------------------------------------------------------------!
  subroutine fstr_setup_contact_interference( ctrl, P )
    implicit none
    integer(kind=kint) :: ctrl
    type(fstr_param_pack) :: P
 
    type(fstr_param), pointer :: fstrPARAM
    type(fstr_solid), pointer :: fstrSOLID
    integer(kind=kint) :: c_contact_if, n, i
    type(fstr_card_slot) :: slot
 
    slot = p%STATE%slot
    fstrparam => p%PARAM
    fstrsolid => p%SOLID
 
    n = fstr_ctrl_get_data_line_n( ctrl )
    c_contact_if = slot%first - 1
    if( fstr_ctrl_get_contact_if( ctrl, n, fstrparam%contact_if(slot%first:slot%last) ) /= 0 ) then
      write(*,*) '### Error: Fail in read in CONTACT_INTERFERENCE definition : ' , c_contact_if
      write(ilog,*) '### Error: Fail in read in CONTACT_INTERFERENCE definition : ', c_contact_if
      stop hecmw_exit_input
    endif
    do i=1, n
      if( check_apply_contact_if(fstrparam%contact_if(c_contact_if+i), fstrsolid%contacts) /= 0) then
        write(*,*) '### Error:(INTERFERENCE) Inconsistence of contact_pair in CONTACTS: ' , i+c_contact_if
        write(ilog,*) '### Error:(INTERFERENCE)  Inconsistence of contact_pair in CONTACTS: ', i+c_contact_if
        stop hecmw_exit_model
      end if
    end do
  end subroutine fstr_setup_contact_interference
 
end module m_fstr_param_setup