fstr_Cutback.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_cutback
  use m_fstr
  use elementinfo
  use mmechgauss
  use mcontactdef
 
  implicit none
 
  logical, private :: is_cutback_active = .false.
 
contains
 
  logical function fstr_cutback_active()
    fstr_cutback_active = is_cutback_active
  end function
 
  subroutine fstr_cutback_init( hecMESH, fstrSOLID, fstrPARAM )
    type(hecmwst_local_mesh) :: hecMESH
    type(fstr_param)         :: fstrPARAM
    type(fstr_solid)         :: fstrSOLID
 
    integer(kind=kint) :: istep, i, j
    integer(kind=kint) :: ng
    integer(kind=kint) :: nthick
    integer(kind=kint) :: ncont, nstate
 
    do istep=1,fstrsolid%nstep_tot
      if( fstrsolid%step_ctrl(istep)%inc_type == stepautoinc ) is_cutback_active = .true.
    end do
 
    if( .not. is_cutback_active ) return
 
    !allocate variables to store analysis state
    !(1)nodal values
    allocate(fstrsolid%unode_bkup(size(fstrsolid%unode)))
    allocate(fstrsolid%QFORCE_bkup(size(fstrsolid%QFORCE)))
    if( associated(fstrsolid%shell_triad) ) allocate(fstrsolid%shell_triad_bkup(size(fstrsolid%shell_triad)))
    if( associated(fstrsolid%shell_drill) ) allocate(fstrsolid%shell_drill_bkup(size(fstrsolid%shell_drill)))
    if( fstrsolid%TEMP_ngrp_tot > 0 .or. fstrsolid%TEMP_irres > 0 ) then
      allocate(fstrsolid%last_temp_bkup(size(fstrsolid%last_temp)))
    endif
 
    !(2)elemental values
    allocate(fstrsolid%elements_bkup(size(fstrsolid%elements)))
    do i=1,size(fstrsolid%elements)
      if (hecmw_is_etype_link( fstrsolid%elements(i)%etype )) cycle
      if (hecmw_is_etype_patch( fstrsolid%elements(i)%etype )) cycle
      ng = numofquadpoints( fstrsolid%elements(i)%etype )
      allocate( fstrsolid%elements_bkup(i)%gausses(ng) )
      do j=1,ng
        fstrsolid%elements_bkup(i)%gausses(j)%pMaterial => fstrsolid%elements(i)%gausses(j)%pMaterial
        call fstr_init_gauss( fstrsolid%elements_bkup(i)%gausses(j) )
      end do
      nthick = fstr_shell_num_thickness_points( fstrsolid%elements(i)%etype )
      if( nthick > 0 ) call fstr_init_shell_layer_gausses( fstrsolid%elements_bkup(i), ng, &
        fstrsolid%elements(i)%shell_nlayer, nthick )
      if( associated( fstrsolid%elements(i)%aux ) ) then
        allocate( fstrsolid%elements_bkup(i)%aux(3,3) )
      endif
    end do
 
    !(3)contact values
    ncont = fstrsolid%n_contacts
    if( associated(fstrsolid%contacts) ) then
      allocate(fstrsolid%contacts_bkup(ncont))
      do i=1,ncont
        nstate = size(fstrsolid%contacts(i)%states)
        allocate(fstrsolid%contacts_bkup(i)%states(nstate))
      end do
    end if
 
    !(4)embed values
    ncont = fstrsolid%n_embeds
    if( associated(fstrsolid%embeds) ) then
      allocate(fstrsolid%embeds_bkup(ncont))
      do i=1,ncont
        nstate = size(fstrsolid%embeds(i)%states)
        allocate(fstrsolid%embeds_bkup(i)%states(nstate))
      end do
    end if
    
  end subroutine
 
  subroutine fstr_cutback_finalize( fstrSOLID )
    type(fstr_solid) :: fstrSOLID
 
    integer(kind=kint) :: i, j
    integer(kind=kint) :: ng
    integer(kind=kint) :: ncont
 
    if( .not. is_cutback_active ) return
 
    !deallocate variables to store analysis state
    !(1)nodal values
    if( associated(fstrsolid%unode_bkup) ) deallocate(fstrsolid%unode_bkup)
    if( associated(fstrsolid%QFORCE_bkup) ) deallocate(fstrsolid%QFORCE_bkup)
    if( associated(fstrsolid%shell_triad_bkup) ) deallocate(fstrsolid%shell_triad_bkup)
    if( associated(fstrsolid%shell_drill_bkup) ) deallocate(fstrsolid%shell_drill_bkup)
    if( fstrsolid%TEMP_ngrp_tot > 0 .or. fstrsolid%TEMP_irres > 0 ) then
      if( associated(fstrsolid%last_temp_bkup) ) deallocate(fstrsolid%last_temp_bkup)
    endif
 
    !(2)elemental values
    do i=1,size(fstrsolid%elements)
      if (hecmw_is_etype_link( fstrsolid%elements(i)%etype )) cycle
      if (hecmw_is_etype_patch( fstrsolid%elements(i)%etype )) cycle
      ng = numofquadpoints( fstrsolid%elements(i)%etype )
      do j=1,ng
        call fstr_finalize_gauss( fstrsolid%elements_bkup(i)%gausses(j) )
      end do
      deallocate( fstrsolid%elements_bkup(i)%gausses )
      call fstr_finalize_shell_layer_gausses( fstrsolid%elements_bkup(i) )
      if( associated( fstrsolid%elements_bkup(i)%aux ) ) then
        deallocate( fstrsolid%elements_bkup(i)%aux )
      endif
    end do
    deallocate(fstrsolid%elements_bkup)
 
    !(3)contact values
    ncont = fstrsolid%n_contacts
    if( associated(fstrsolid%contacts) ) then
      do i=1,ncont
        deallocate(fstrsolid%contacts_bkup(i)%states)
      end do
      deallocate(fstrsolid%contacts_bkup)
    end if
 
    !(4)embed values
    ncont = fstrsolid%n_embeds
    if( associated(fstrsolid%embeds) ) then
      do i=1,ncont
        deallocate(fstrsolid%embeds_bkup(i)%states)
      end do
      deallocate(fstrsolid%embeds_bkup)
    end if
 
        
  end subroutine
 
  subroutine fstr_cutback_save( fstrSOLID, infoCTChange, infoCTChange_bak )
    type(fstr_solid), intent(inout)              :: fstrSOLID
    type(fstr_info_contactchange), intent(inout) :: infoCTChange
    type(fstr_info_contactchange), intent(inout) :: infoCTChange_bak
 
    integer(kind=kint) :: i, j
    integer(kind=kint) :: ng
    integer(kind=kint) :: ncont, nstate
 
    if( .not. is_cutback_active ) return
 
    !(1)nodal values
    do i=1,size(fstrsolid%unode)
      fstrsolid%unode_bkup(i) = fstrsolid%unode(i)
    end do
    do i=1,size(fstrsolid%QFORCE)
      fstrsolid%QFORCE_bkup(i) = fstrsolid%QFORCE(i)
    end do
    if( associated(fstrsolid%shell_triad_bkup) ) then
      do i=1,size(fstrsolid%shell_triad)
        fstrsolid%shell_triad_bkup(i) = fstrsolid%shell_triad(i)
      end do
    endif
    if( associated(fstrsolid%shell_drill_bkup) ) then
      do i=1,size(fstrsolid%shell_drill)
        fstrsolid%shell_drill_bkup(i) = fstrsolid%shell_drill(i)
      end do
    endif
    if( fstrsolid%TEMP_ngrp_tot > 0 .or. fstrsolid%TEMP_irres > 0 ) then
      do i=1,size(fstrsolid%last_temp)
        fstrsolid%last_temp_bkup(i) = fstrsolid%last_temp(i)
      end do
    endif
 
    !(2)elemental values
    do i=1,size(fstrsolid%elements)
      if (hecmw_is_etype_link( fstrsolid%elements(i)%etype )) cycle
      if (hecmw_is_etype_patch( fstrsolid%elements(i)%etype )) cycle
      ng = numofquadpoints( fstrsolid%elements(i)%etype )
      do j=1,ng
        call fstr_copy_gauss( fstrsolid%elements(i)%gausses(j), fstrsolid%elements_bkup(i)%gausses(j) )
      end do
      call fstr_copy_shell_layer_gausses( fstrsolid%elements(i), fstrsolid%elements_bkup(i) )
      if( associated( fstrsolid%elements(i)%aux ) ) then
        fstrsolid%elements_bkup(i)%aux(:,:) = fstrsolid%elements(i)%aux(:,:)
      endif
    end do
 
    !(3)contact values
    ncont = fstrsolid%n_contacts
    if( associated(fstrsolid%contacts) ) then
      do i=1,ncont
        nstate = size(fstrsolid%contacts(i)%states)
        do j=1,nstate
          call contact_state_copy(fstrsolid%contacts(i)%states(j), fstrsolid%contacts_bkup(i)%states(j))
        enddo
      end do
      infoctchange_bak = infoctchange
    end if
 
    !(4)embed values
    ncont = fstrsolid%n_embeds
    if( associated(fstrsolid%embeds) ) then
      do i=1,ncont
        nstate = size(fstrsolid%embeds(i)%states)
        do j=1,nstate
          call contact_state_copy(fstrsolid%embeds(i)%states(j), fstrsolid%embeds_bkup(i)%states(j))
        enddo
      end do
      infoctchange_bak = infoctchange
    end if
  end subroutine
 
  subroutine fstr_cutback_load( fstrSOLID, infoCTChange, infoCTChange_bak )
    type(fstr_solid), intent(inout)              :: fstrSOLID
    type(fstr_info_contactchange), intent(inout) :: infoCTChange
    type(fstr_info_contactchange), intent(inout) :: infoCTChange_bak
 
    integer(kind=kint) :: i, j
    integer(kind=kint) :: ng
    integer(kind=kint) :: ncont, nstate
 
    if( .not. is_cutback_active ) return
 
    !(1)nodal values
    do i=1,size(fstrsolid%unode)
      fstrsolid%unode(i) = fstrsolid%unode_bkup(i)
    end do
    do i=1,size(fstrsolid%QFORCE)
      fstrsolid%QFORCE(i) = fstrsolid%QFORCE_bkup(i)
    end do
    if( associated(fstrsolid%shell_triad_bkup) ) then
      do i=1,size(fstrsolid%shell_triad)
        fstrsolid%shell_triad(i) = fstrsolid%shell_triad_bkup(i)
        fstrsolid%shell_dtriad(i) = fstrsolid%shell_triad_bkup(i)
      end do
    endif
    if( associated(fstrsolid%shell_drill_bkup) ) then
      do i=1,size(fstrsolid%shell_drill)
        fstrsolid%shell_drill(i) = fstrsolid%shell_drill_bkup(i)
        fstrsolid%shell_ddrill(i) = fstrsolid%shell_drill_bkup(i)
      end do
    endif
    if( fstrsolid%TEMP_ngrp_tot > 0 .or. fstrsolid%TEMP_irres > 0 ) then
      do i=1,size(fstrsolid%last_temp)
        fstrsolid%last_temp(i) = fstrsolid%last_temp_bkup(i)
      end do
    endif
 
    !(2)elemental values
    do i=1,size(fstrsolid%elements)
      if (hecmw_is_etype_link( fstrsolid%elements(i)%etype )) cycle
      if (hecmw_is_etype_patch( fstrsolid%elements(i)%etype )) cycle
      ng = numofquadpoints( fstrsolid%elements(i)%etype )
      do j=1,ng
        call fstr_copy_gauss( fstrsolid%elements_bkup(i)%gausses(j), fstrsolid%elements(i)%gausses(j) )
      end do
      call fstr_copy_shell_layer_gausses( fstrsolid%elements_bkup(i), fstrsolid%elements(i) )
      if( associated( fstrsolid%elements(i)%aux ) ) then
        fstrsolid%elements(i)%aux(:,:) = fstrsolid%elements_bkup(i)%aux(:,:)
      endif
    end do
 
    !(3)contact values
    ncont = fstrsolid%n_contacts
    if( associated(fstrsolid%contacts) ) then
      do i=1,ncont
        nstate = size(fstrsolid%contacts(i)%states)
        do j=1,nstate
          call contact_state_copy(fstrsolid%contacts_bkup(i)%states(j), fstrsolid%contacts(i)%states(j))
        enddo
      end do
      infoctchange = infoctchange_bak
    end if
 
    !(4)embed values
    ncont = fstrsolid%n_embeds
    if( associated(fstrsolid%embeds) ) then
      do i=1,ncont
        nstate = size(fstrsolid%embeds(i)%states)
        do j=1,nstate
          call contact_state_copy(fstrsolid%embeds_bkup(i)%states(j), fstrsolid%embeds(i)%states(j))
        enddo
      end do
      infoctchange = infoctchange_bak
    end if
 
  end subroutine
 
end module m_fstr_cutback