check_surface_state.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    check_surface_state             ../engine/source/interfaces/interf/check_surface_state.F
!||--- called by ------------------------------------------------------
!||    find_surface_from_remote_proc   ../engine/source/interfaces/interf/find_surface_from_remote_proc.F
!||    resol                           ../engine/source/engine/resol.f
!||--- calls      -----------------------------------------------------
!||    check_active_elem_edge          ../engine/source/interfaces/interf/check_active_elem_edge.F
!||    my_barrier                      ../engine/source/system/machine.F
!||--- uses       -----------------------------------------------------
!||    intbufdef_mod                   ../common_source/modules/interfaces/intbufdef_mod.F90
!||    shooting_node_mod               ../engine/share/modules/shooting_node_mod.F
!||====================================================================
        SUBROUTINE check_surface_state( ITASK,SURFARCE_NB,SURFACE_ID,SHIFT_INTERFACE,INTBUF_TAB,
     .                                  IPARI,GEO,
     .                                  IXS,IXC,IXT,IXP,IXR,IXTG,IXS10,
     .                                  ADDCNEL,CNEL,TAG_NODE,TAG_ELEM,SHOOT_STRUCT )
!$COMMENT
!       CHECK_SURFACE_STATE description
!           check the state of an surface (active or not)
!       CHECK_SURFACE_STATE organization
!           loop over a list of surface :
!           -check if 1 or more element associated to the surface is/are active
!           - if there is no active element, the surface is deactivate
!           - additional treatment for interface type 24 & 25 : save the list of deactivated surface
!             --> need to send them to remote proc for neighbouring surface deactivation
!$ENDCOMMENT
        USE intbufdef_mod
        USE shooting_node_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "task_c.inc"
#include      "com04_c.inc"
#include      "scr17_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER, INTENT(in) :: ITASK ! omp thread ID
        INTEGER, INTENT(in) :: SURFARCE_NB  ! number of local deactivated surface
        INTEGER, DIMENSION(SURFARCE_NB), INTENT(in) :: SURFACE_ID  ! id of surface that need to be deactivated
        INTEGER, DIMENSION(NINTER+1,2), INTENT(in) :: SHIFT_INTERFACE ! interface shift
        TYPE(intbuf_struct_), DIMENSION(NINTER), INTENT(inout) :: INTBUF_TAB    ! interface data 
        INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI
 
        INTEGER, DIMENSION(NIXS,NUMELS), INTENT(in) :: IXS   ! solid array
        INTEGER, DIMENSION(NIXC,NUMELC), INTENT(in) :: IXC   ! shell array
        INTEGER, DIMENSION(NIXT,NUMELT), INTENT(in) :: IXT! truss array
        INTEGER, DIMENSION(NIXP,NUMELP), INTENT(in) :: IXP! beam array
        INTEGER, DIMENSION(NIXR,NUMELR), INTENT(in) :: IXR! spring array
        INTEGER, DIMENSION(NIXTG,NUMELTG), INTENT(in) :: IXTG! triangle array
        INTEGER, DIMENSION(6,NUMELS10), INTENT(in) :: IXS10!< tetra10 data
        INTEGER, DIMENSION(0:NUMNOD+1), INTENT(in) :: ADDCNEL ! address for the CNEL array
        my_real, DIMENSION(NPROPG,NUMGEO), INTENT(in) :: geo
        INTEGER, DIMENSION(0:LCNEL), INTENT(in) :: CNEL ! connectivity node-->element
        INTEGER, DIMENSION(NUMNOD), INTENT(inout) :: TAG_NODE
        INTEGER, DIMENSION(NUMELS+NUMELQ+NUMELC+NUMELT+NUMELP+NUMELR+NUMELTG), INTENT(inout) :: TAG_ELEM
        TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT ! structure for shooting node algo   
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        LOGICAL :: DEACTIVATION,ACTIVATION,TYPE_INTER
        INTEGER :: I,K,FIRST,LAST
        INTEGER :: NIN,ID_INTER,NUMBER_INTER
        INTEGER :: ITY,IDEL
        INTEGER :: N1,N2,N3,N4
        INTEGER :: NUMBER_NODE
        INTEGER :: DICHOTOMIC_SEARCH_I_ASC  ! function
        INTEGER :: MY_REAL_TASK_ID ! real task id : itask is used in a strange way here : -1 if there is no omp // (in the mpi comm)
        INTEGER, DIMENSION(:), ALLOCATABLE :: NUMBER_SAVED_SURFACE_TYP24_25 ! number of deactivated surface for interface type 24 or 25
        INTEGER, DIMENSION(SURFARCE_NB) :: SAVED_SURFACE_TYP24_25 ! list of deactivated surface for interface type 24 or 25
        SAVE number_saved_surface_typ24_25
        INTEGER :: OFFSET_TASK ! offset to point to the right place in the array SHOOT_STRUCT%REMOTE_SURF
        INTEGER :: LOW_BOUND,UP_BOUND ! bounds
        INTEGER :: TOTAL_NUMBER_SURFACE ! total number of deleted surface
        INTEGER, DIMENSION(:), ALLOCATABLE :: SAVED_SURFACE ! temporary array 
        INTEGER :: NB_CONNECTED_ELM ! number of element connected to a sefment/surface
        INTEGER :: TOTAL_NUMBER_NEW_SURFACE ! total number of new active surface/
        INTEGER, DIMENSION(:), ALLOCATABLE :: NUMBER_NEW_SURFACE ! number of new active surface
        SAVE number_new_surface
        INTEGER, DIMENSION(SURFARCE_NB) :: NEW_SURFACE ! list of new surface
C-----------------------------------------------
        IF(itask==-1) THEN
          first = 1
          last = surfarce_nb
          my_real_task_id = 1
        ELSE
          first = 1 + itask * (surfarce_nb / nthread)
          last = (itask + 1) * (surfarce_nb / nthread)
          IF((itask+1)==nthread) last = surfarce_nb
          my_real_task_id = itask+1
        ENDIF
        IF(my_real_task_id==1) THEN
          ALLOCATE( number_saved_surface_typ24_25(nthread) )
          ALLOCATE( number_new_surface(nthread) )
        ENDIF
        IF(itask/=-1) CALL my_barrier( )
        number_inter = shift_interface(ninter+1,2)
        number_saved_surface_typ24_25(my_real_task_id) = 0
        number_new_surface(my_real_task_id) = 0
        ! --------------------------
        ! loop over the deactivated surface
        DO i=first,last
          k = surface_id(i)  ! get the global surface id
          id_inter = dichotomic_search_i_asc(k, shift_interface(1,1), number_inter+1) ! find the interface of the surface
          nin = shift_interface(id_inter,2)
          k = k - shift_interface(id_inter,1) + 1 ! get the surface id in the NIN interface
          ity = ipari(7,nin)
          idel = ipari(17,nin)
          activation =.false.
          type_inter = (ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.(ipari(100,nin)==0.AND.ity==25))
          ! --------------
          IF(itask==-1) THEN
            IF((type_inter.AND.idel==1).OR.(ipari(100,nin)/=0.AND.ity==25)) THEN
              shoot_struct%INTER(nin)%REMOTE_ELM_M(k) = shoot_struct%INTER(nin)%REMOTE_ELM_M(k) - 1
            ENDIF
          ENDIF
          ! --------------
 
          ! --------------
          IF(ipari(100,nin)/=0.AND.ity==25) THEN
            shoot_struct%INTER(nin)%NB_ELM_M(k) = shoot_struct%INTER(nin)%NB_ELM_M(k) - 1
          ENDIF
          ! --------------
          ! --------------
          deactivation = .false.
          IF((type_inter.AND.idel==1).OR.(ipari(100,nin)/=0.AND.ity==25)) THEN
            n1 = intbuf_tab(nin)%IRECTM((k-1)*4+1)
            n2 = intbuf_tab(nin)%IRECTM((k-1)*4+2)
            n3 = intbuf_tab(nin)%IRECTM((k-1)*4+3)
            n4 = intbuf_tab(nin)%IRECTM((k-1)*4+4)
            number_node = 4
            IF(n3==n4) number_node = 3
            IF(shoot_struct%INTER(nin)%REMOTE_ELM_M(k)<1) THEN
              CALL check_active_elem_edge( number_node, n1,n2,n3,n4,
     .                                     deactivation,geo,ixs,ixc,
     .                                     ixt,ixp,ixr,ixtg,ixs10,addcnel,cnel,
     .                                     tag_node,tag_elem)
            ELSE
              deactivation = .false.
            ENDIF
          ELSEIF(type_inter.AND.idel==2) THEN
              deactivation = .true.
          ENDIF
 
          IF(.NOT.deactivation.AND.(ipari(100,nin)/=0.AND.ity==25)) THEN
            nb_connected_elm = shoot_struct%INTER(nin)%NB_ELM_M(k)
            ! ---------
c            IF((NB_CONNECTED_ELM<1).AND.(INTBUF_TAB(NIN)%STFM(k)>ZERO)) THEN
c              DEACTIVATION=.TRUE.
            IF(nb_connected_elm==1.AND.(intbuf_tab(nin)%STFM(k)<zero)) THEN
              activation = .true.
            ENDIF
            ! ---------
          ENDIF
          ! --------------
 
          ! --------------
          ! check if the surface is active, if yes --> deactivate it
          IF(deactivation) THEN
            intbuf_tab(nin)%STFM(k)  = zero
            IF(ity==24.OR.ity==25) THEN
              number_saved_surface_typ24_25(my_real_task_id) = number_saved_surface_typ24_25(my_real_task_id) + 1
              saved_surface_typ24_25(number_saved_surface_typ24_25(my_real_task_id)) = surface_id(i)
            ENDIF
          ENDIF
          ! --------------
 
          ! --------------
          ! the surface was not active, need to active it 
          IF(activation) THEN
            intbuf_tab(nin)%STFM(k) = abs(intbuf_tab(nin)%STFM(k))
            number_new_surface(my_real_task_id) = number_new_surface(my_real_task_id) + 1
            new_surface(number_new_surface(my_real_task_id)) = surface_id(i)
          ENDIF
          ! --------------
 
        ENDDO
        ! --------------------------
       
        ! --------------------------
        ! Only for interface type 24 & 25 :
        ! need to save the surface id and send it to a remote processor
        ! the remote processor will also deactivated the surface for a neighbourhood question
        offset_task = shoot_struct%NUMBER_REMOTE_SURF
        IF(itask/=-1) THEN
          CALL my_barrier()
          IF(itask>0) THEN
              DO i=1,itask
                offset_task = offset_task + number_saved_surface_typ24_25(i)
              ENDDO
          ENDIF
          total_number_surface = 0
          DO i=1,nthread
            total_number_surface = total_number_surface +  number_saved_surface_typ24_25(i)
          ENDDO
        ELSE
          total_number_surface = number_saved_surface_typ24_25(my_real_task_id)        
        ENDIF
        ! --------------------------
        IF(total_number_surface>0) THEN
          IF(my_real_task_id==1) THEN
            IF( total_number_surface+shoot_struct%NUMBER_REMOTE_SURF > shoot_struct%SIZE_REMOTE_SURF) THEN
              ALLOCATE( saved_surface(shoot_struct%NUMBER_REMOTE_SURF) )
              saved_surface(1:shoot_struct%NUMBER_REMOTE_SURF) = shoot_struct%REMOTE_SURF(1:shoot_struct%NUMBER_REMOTE_SURF)
              DEALLOCATE( shoot_struct%REMOTE_SURF )
              shoot_struct%SIZE_REMOTE_SURF = total_number_surface+shoot_struct%NUMBER_REMOTE_SURF
              ALLOCATE( shoot_struct%REMOTE_SURF(shoot_struct%SIZE_REMOTE_SURF) )
              shoot_struct%REMOTE_SURF(1:shoot_struct%NUMBER_REMOTE_SURF) = saved_surface(1:shoot_struct%NUMBER_REMOTE_SURF)
              DEALLOCATE( saved_surface )
            ENDIF
          ENDIF
 
          IF(itask/=-1) CALL my_barrier()
          low_bound = 1
          up_bound = number_saved_surface_typ24_25(my_real_task_id)
          shoot_struct%REMOTE_SURF(low_bound+offset_task:up_bound+offset_task) = saved_surface_typ24_25(low_bound:up_bound)
          IF(itask/=-1) CALL my_barrier()
          IF(my_real_task_id==1) shoot_struct%NUMBER_REMOTE_SURF = shoot_struct%NUMBER_REMOTE_SURF + total_number_surface
        ENDIF
        ! --------------------------
 
        ! --------------------------
        ! Only for interface type 25 :
        ! need to save the new surface id to find the new neighbours
        offset_task = shoot_struct%NUMBER_NEW_SURF
        IF(itask/=-1) THEN
          CALL my_barrier()
          IF(itask>0) THEN
            DO i=1,itask
              offset_task = offset_task + number_new_surface(i)
            ENDDO
          ENDIF
          total_number_new_surface = 0
          DO i=1,nthread
            total_number_new_surface = total_number_new_surface +  number_new_surface(i)
          ENDDO
        ELSE
          total_number_new_surface = number_new_surface(my_real_task_id)        
        ENDIF
        ! --------------------------
        IF(total_number_new_surface>0) THEN
          IF(my_real_task_id==1) THEN
            IF( total_number_new_surface+shoot_struct%NUMBER_NEW_SURF > shoot_struct%SIZE_NEW_SURF) THEN
              ALLOCATE( saved_surface(shoot_struct%NUMBER_NEW_SURF) )
              saved_surface(1:shoot_struct%NUMBER_NEW_SURF) = shoot_struct%NEW_SURF(1:shoot_struct%NUMBER_NEW_SURF)
              DEALLOCATE( shoot_struct%NEW_SURF )
              shoot_struct%SIZE_NEW_SURF = total_number_new_surface+shoot_struct%NUMBER_NEW_SURF
              ALLOCATE( shoot_struct%NEW_SURF(shoot_struct%SIZE_NEW_SURF) )
              shoot_struct%NEW_SURF(1:shoot_struct%NUMBER_NEW_SURF) = saved_surface(1:shoot_struct%NUMBER_NEW_SURF)
              DEALLOCATE( saved_surface )
            ENDIF
          ENDIF
          IF(itask/=-1) CALL my_barrier()
          low_bound = 1
          up_bound = number_new_surface(my_real_task_id)
          shoot_struct%NEW_SURF(low_bound+offset_task:up_bound+offset_task) = new_surface(low_bound:up_bound)
          IF(itask/=-1) CALL my_barrier()
          IF(my_real_task_id==1) shoot_struct%NUMBER_NEW_SURF = shoot_struct%NUMBER_NEW_SURF + total_number_new_surface
        ENDIF
        ! --------------------------
 
 
        IF(itask/=-1) CALL my_barrier( )
 
        IF(my_real_task_id==1) THEN
          DEALLOCATE( number_saved_surface_typ24_25 )
          DEALLOCATE( number_new_surface )
        ENDIF
 
        RETURN
        END SUBROUTINE check_surface_state