update_struct_int21.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/.
!||====================================================================
!||    update_struct_int21   ../engine/source/interfaces/int21/update_struct_int21.F
!||--- called by ------------------------------------------------------
!||    i21main_tri           ../engine/source/interfaces/intsort/i21main_tri.F
!||--- calls      -----------------------------------------------------
!||    my_barrier            ../engine/source/system/machine.F
!||--- uses       -----------------------------------------------------
!||    intstamp_glob_mod     ../engine/share/modules/intstamp_glob_mod.F
!||    message_mod           ../engine/share/message_module/message_mod.F
!||    tri7box               ../engine/share/modules/tri7box.F
!||====================================================================
       SUBROUTINE update_struct_int21(
     1                          CAND_E, II_STOK, IFORM , NIN   , NMN,
     2                          INTTH, MNDD   , MSR_L , IRECTT )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE intstamp_glob_mod
      USE tri7box
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "task_c.inc"
#include      "parit_c.inc"
#include      "spmd_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  NIN,NMN,IFORM
      INTEGER  MSR_L(*),MNDD(*)
      INTEGER CAND_E(*)
      INTEGER II_STOK,INTTH,IRECTT(4,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, J, IP0, IP1, II,IFLAGLOADP,
     .        N,L,PP,J_STOK,IAD(NSPMD),
     .        tag(nmn),nm(4),nodfi,ptr, ierror1,ierror2, ierror3,
     .        ierror4,lskyfi
 
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
C UPDATE STRUCTURE NMNSI and NMNFI FOR SPMD COMMUNICATION
C
       iflagloadp = 0
 
        IF(nspmd > 1.AND.(intth == 2.OR.iflagloadp > 0)) THEN
            CALL my_barrier
!$OMP MASTER
            tag(1:nmn)=0
            nodfi = 0
            nmnfi(nin)%P(1:nspmd) = 0
            DO i=1,ii_stok 
                l = cand_e(i)
                IF(l/=0) THEN             
                    nm(1:4) = irectt(1:4,l)
                    DO j=1,4
                        ii = nm(j)
                        pp = mndd(ii)
                        IF(pp/=0.AND.tag(ii) == 0) THEN                     
                            nodfi = nodfi + 1
                            nmnfi(nin)%P(pp) = nmnfi(nin)%P(pp) +1
                            tag(ii)=1
                        ENDIF 
                    ENDDO
                ENDIF
            ENDDO 
 
            IF(ASSOCIATED( nmvfi(nin)%P )) DEALLOCATE(nmvfi(nin)%P)
            ALLOCATE(nmvfi(nin)%P(nodfi),stat=ierror1)
C
            iad(1)=1
            DO i=1,nspmd-1
                iad(i+1) = iad(i)+nmnfi(nin)%P(i)
            ENDDO
 
C
            tag(1:nmn)=0
            DO i=1,ii_stok 
                l = cand_e(i)
                IF(l/=0) THEN 
                    nm(1:4) = irectt(1:4,l)  
                    DO j=1,4
                        ii=nm(j)
                        pp = mndd(ii)
                        IF(pp/=0.AND.tag(ii)==0)  THEN
                            ptr = iad(pp)
                            nmvfi(nin)%P(ptr) = ii
                            tag(ii)=1
                            iad(pp)=iad(pp)+1
                            msr_l(ii) = -ptr
                        ENDIF
                    ENDDO
                ENDIF
            ENDDO 
       
 
C
            IF(iform /= 0) THEN 
                IF(iparit==0) THEN
                    IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror2)
                    DO i = 1, nodfi*nthread
                        fthefi(nin)%P(i) = zero
                    ENDDO
                ELSE
                    IF(ASSOCIATED(ftheskyfi(nin)%P)) DEALLOCATE(ftheskyfi(nin)%P)
                    lskyfi = nodfi*multimax
                    nlskyfi(nin) = lskyfi
                    IF(lskyfi>0) THEN
                        ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror3)
                        ALLOCATE(ftheskyfi(nin)%P(lskyfi),stat=ierror4)
                    ENDIF
                ENDIF
            ENDIF
 
            IF (iflagloadp > 0) THEN
                IF(nodfi>0) THEN 
                  IF(ASSOCIATED( tagncontfi(nin)%P )) DEALLOCATE(tagncontfi(nin)%P)
                   ALLOCATE(tagncontfi(nin)%P(nodfi),stat=ierror2)   
                     DO i = 1, nodfi
                        tagncontfi(nin)%P(i) = 0
                    ENDDO
                ENDIF            
            ENDIF
!$OMP END MASTER
            CALL my_barrier     !   there isn't any implicit barrier at the end 
                                !   of an omp main condition
        ENDIF    
 
        RETURN
        END SUBROUTINE update_struct_int21