fstr_ctrl_modifier.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 fstr_ctrl_modifier
 
  use fstr_setup_util
  use hecmw_util
  implicit none
 
contains
 
  subroutine fstr_append_mpc( np, nodes, dofs, values, mpcs )
    integer, intent(in)                :: np
    integer, intent(in)                :: nodes(np)
    integer, intent(in)                :: dofs(np)
    real(kind=kreal), intent(in)       :: values(np+1) 
    type( hecmwst_mpc ), intent(inout) :: mpcs
 
    integer :: i, n_mpc, old_size, new_size
    n_mpc = mpcs%n_mpc
    new_size= n_mpc+1
    mpcs%n_mpc = new_size
    call fstr_expand_index_array( mpcs%mpc_index, n_mpc+1, new_size+1 )
    call fstr_expand_real_array( mpcs%mpc_const, n_mpc, n_mpc+1 )
    old_size = mpcs%mpc_index( n_mpc )
    new_size = old_size+np
    call fstr_expand_integer_array( mpcs%mpc_item, old_size, new_size )
    call fstr_expand_integer_array( mpcs%mpc_dof, old_size, new_size )
    call fstr_expand_real_array( mpcs%mpc_val, old_size, new_size )
 
    mpcs%mpc_index(mpcs%n_mpc) = mpcs%mpc_index(mpcs%n_mpc-1)+np
    mpcs%mpc_const(mpcs%n_mpc) = values(np+1)
    do i=1,np
      mpcs%mpc_item(old_size+i) = nodes(i)
      mpcs%mpc_dof(old_size+i) = dofs(i)
      mpcs%mpc_val(old_size+i) = values(i)
    enddo
  end subroutine
 
  subroutine fstr_delete_mpc( np, mpcs )
    integer, intent(in)                :: np
    type( hecmwst_mpc ), intent(inout) :: mpcs
 
    integer :: n_mpc, old_size, nitem
    n_mpc = mpcs%n_mpc
    old_size = mpcs%mpc_index( n_mpc )
    nitem = old_size- mpcs%mpc_index( n_mpc-np )
    call fstr_delete_real_array( mpcs%mpc_val, old_size, nitem )
    call fstr_delete_integer_array( mpcs%mpc_dof, old_size, nitem )
    call fstr_delete_integer_array( mpcs%mpc_item, old_size, nitem )
 
    call fstr_delete_real_array( mpcs%mpc_const, n_mpc, np )
    call fstr_delete_index_array( mpcs%mpc_index, n_mpc, np )
    mpcs%n_mpc = n_mpc-np
  end subroutine
 
end module