spmd_fiadd25e_pon.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/.
!||====================================================================
!||    spmd_fiadd25e_pon   ../engine/source/mpi/interfaces/spmd_fiadd25e_pon.F
!||--- called by ------------------------------------------------------
!||    spmd_i7fcom_pon     ../engine/source/mpi/forces/spmd_i7fcom_pon.F
!||--- calls      -----------------------------------------------------
!||    ancmsg              ../engine/source/output/message/message.F
!||    arret               ../engine/source/system/arret.F
!||    ibcoff              ../engine/source/interfaces/interf/ibcoff.F
!||--- uses       -----------------------------------------------------
!||    debug_mod           ../engine/share/modules/debug_mod.F
!||    h3d_mod             ../engine/share/modules/h3d_mod.F
!||    message_mod         ../engine/share/message_module/message_mod.F
!||    output_mod          ../common_source/modules/output/output_mod.F90
!||====================================================================
      SUBROUTINE spmd_fiadd25e_pon(OUTPUT,
     1       NB     ,LEN    ,BUFR   ,NSV     ,FSKYI,
     2       ISKY   ,IBC    ,ISECIN ,NOINT   ,IBAG ,
     3       ICODT  ,SECFCUM,NSTRF  ,ICONTACT,FCONT,
     4       INACTI ,IADM   ,INTTH  ,FTHESKYI,CONDNSKYI,
     5       H3D_DATA,LEDGE ,SEDGE  ,NEDGE   ,NIN  ,
     6       TAGNCONT,KLOADPINTER,LOADPINTER,LOADP_HYD_INTER)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE h3d_mod
      USE debug_mod
      USE output_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      "parit_c.inc"
#include      "scr07_c.inc"
#include      "scr14_c.inc"
#include      "scr16_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com06_c.inc"
#include      "com08_c.inc"
#include      "assert.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(output_), intent(inout) :: OUTPUT
      INTEGER NB, LEN, IBC  ,ISECIN  ,IBAG , NOINT, INACTI,
     .        NSV(*), ISKY(*), ICODT(*), NSTRF(*),ICONTACT(*),
     .        TAGNCONT(NLOADP_HYD_INTER,NUMNOD),
     .        KLOADPINTER(NINTER+1),LOADPINTER(NINTER*NLOADP_HYD),
     .        LOADP_HYD_INTER(NLOADP_HYD),
     .        iadm,intth,nin
      INTEGER :: SEDGE,NEDGE
      INTEGER :: LEDGE(SEDGE,NEDGE)
      my_real
     .        BUFR(LEN,*),
     .        FSKYI(LSKYI,NFSKYI), SECFCUM(7,NUMNOD,NSECT),
     .        FCONT(3,*),FTHESKYI(LSKYI),CONDNSKYI(LSKYI)
      TYPE(h3d_database) :: H3D_DATA
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER I, J, II, N, NOD, K0, K1S, IBCS, IBCM, NBINTER,
     .        NISKY_SAV,NOD1,NOD2,PP,PPL
      INTEGER NB_EDGE
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      IF ((nisky+nb)> lskyi)THEN
           CALL ancmsg(msgid=26,anmode=aninfo)
           CALL arret(2)
      ENDIF
C
      nb_edge = nb 
      nisky_sav = nisky
      DO i = 1, nb_edge
        n = nint(bufr(1,i))
        assert(n > 0)
        assert(n <= nedge)
        IF(intth == 0 ) THEN
C issue: not sure to receive the FKSKY in this order
C#ifdef D_ES
C         IF(LEDGE(8,N) == D_ES) THEN
C          WRITE(6,*) "EDGE:",N,LEDGE(5,N),LEDGE(6,N),BUFR(10,I)
C         ENDIF
C#endif
          nod = ledge(5,n)
          nisky = nisky + 1
          fskyi(nisky,1)=bufr(2,i)
          fskyi(nisky,2)=bufr(3,i)
          fskyi(nisky,3)=bufr(4,i)
          fskyi(nisky,4)=bufr(5,i)
C         IF(KDTINT /= 0) FSKYI(NISKY,5) = BUFR(6,I)
          isky(nisky) = nod
 
C#ifdef D_EM
C          IF(ITAB_DEBUG(NOD) == 29442) THEN
C            WRITE(6,"(A,I10,3Z20)") __FILE__,ITAB_DEBUG(NOD),BUFR(2,I),BUFR(3,I),BUFR(4,I)
C          ENDIF
C#endif
 
          assert(bufr(6,i) == bufr(1,i))
 
          nod = ledge(6,n)
          nisky = nisky + 1
          fskyi(nisky,1)=bufr(7,i)
          fskyi(nisky,2)=bufr(8,i)
          fskyi(nisky,3)=bufr(9,i)
          fskyi(nisky,4)=bufr(10,i)
C         IF(KDTINT /= 0) FSKYI(NISKY,5) = BUFR(11,I)
          isky(nisky) = nod
 
 
C#ifdef D_EM
C          IF(ITAB_DEBUG(NOD) == 29442) THEN
C            WRITE(6,"(A,I10,3Z20)") __FILE__,ITAB_DEBUG(NOD),BUFR(7,I),BUFR(8,I),BUFR(9,I)
C          ENDIF
C#endif
 
        ENDIF
      ENDDO
      
      IF(intth /= 0 ) THEN
       ! THERMAL ANALYSIS + TYPE25 not available yet
       assert(.false.)
C        NISKY = NISKY_SAV
C        DO I = 1, NB
C         NISKY = NISKY + 1
C         FTHESKYI(NISKY)=BUFR(TEMP_SIZ,I)
C        ENDDO
C        TEMP_SIZ=TEMP_SIZ+1
C        
C        IF(NODADT_THERM ==1) THEN
C          NISKY = NISKY_SAV
C          DO I = 1, NB
C            NISKY = NISKY + 1
C            CONDNSKYI(NISKY)=BUFR(TEMP_SIZ,I)
C          ENDDO
C          TEMP_SIZ=TEMP_SIZ+1
C        ENDIF        
      ENDIF
 
 
C
C continuation of i7for3 and i10for3 processing on secondary node
C
      IF((anim_v(4)+outp_v(4)+h3d_data%N_VECT_CONT >0.AND.
     .   ((tt>=output%TANIM .AND. tt<=output%TANIM_STOP).OR.tt>=toutp.OR.(tt>=h3d_data%TH3D.AND.tt<=h3d_data%TH3D_STOP).OR.
     .   (manim>=4.AND.manim<=15)))
     .   .OR.anim_v(26)+h3d_data%N_VECT_CONT_MAX>0)THEN
C Anim FCONT
        DO i = 1, nb_edge
          n = nint(bufr(1,i))
          nod = ledge(5,n)
          fcont(1,nod)=fcont(1,nod)+bufr(2,i)
          fcont(2,nod)=fcont(2,nod)+bufr(3,i)
          fcont(3,nod)=fcont(3,nod)+bufr(4,i)
          nod = ledge(6,n)
          fcont(1,nod)=fcont(1,nod)+bufr(7,i)
          fcont(2,nod)=fcont(2,nod)+bufr(8,i)
          fcont(3,nod)=fcont(3,nod)+bufr(9,i)
        END DO
      END IF
C
C------------For /LOAD/PRESSURE tag nodes in contact-------------
         IF(nintloadp > 0) THEN
           DO i = 1, nb
              n = nint(bufr(1,i))
              nod1 = ledge(5,n)
              nod2 = ledge(6,n)
              DO pp = kloadpinter(nin)+1, kloadpinter(nin+1) 
                 ppl = loadp_hyd_inter(pp)
                 tagncont(ppl,nod1) = 1
                 tagncont(ppl,nod2) = 1
              ENDDO
            ENDDO
         ENDIF
C
         IF(isecin>0)THEN
C     Sections
            k0=nstrf(25)
            IF(nstrf(1)+nstrf(2)/=0)THEN
               DO i=1,nsect
                  nbinter=nstrf(k0+14)
                  k1s=k0+30
                  DO j=1,nbinter
                     IF(nstrf(k1s)==noint)THEN
                        IF(isecut/=0)THEN
                           DO ii = 1, nb
                              n = nint(bufr(1,ii))
                              nod = ledge(5,n)
                              IF(secfcum(4,nod,i)==1.)THEN
                                 secfcum(1,nod,i)=secfcum(1,nod,i)+bufr(2,ii)
                                 secfcum(2,nod,i)=secfcum(2,nod,i)+bufr(3,ii)
                                 secfcum(3,nod,i)=secfcum(3,nod,i)+bufr(4,ii)
                              ENDIF
                              nod = ledge(6,n)
                              IF(secfcum(4,nod,i)==1.)THEN
                                 secfcum(1,nod,i)=secfcum(1,nod,i)+bufr(7,ii)
                                 secfcum(2,nod,i)=secfcum(2,nod,i)+bufr(8,ii)
                                 secfcum(3,nod,i)=secfcum(3,nod,i)+bufr(9,ii)
                              ENDIF
                           ENDDO
                        ENDIF
                     ENDIF
                     k1s=k1s+1
                  ENDDO
                  k0=nstrf(k0+24)
               ENDDO
            ENDIF
         ENDIF
C     
         IF((ibag/=0.AND.inacti/=7).OR.
     .        (iadm/=0).OR.(idamp_rdof/=0)) THEN ! warning: conflict inacti = 7 and ibag = 3
C     Airbags IBAG
            DO i = 1, nb
               IF(bufr(2,i)/=zero.OR.bufr(3,i)/=zero.OR.
     +              bufr(4,i)/=zero) THEN
                  n = nint(bufr(1,i))
                  nod = ledge(5,n)
                  icontact(nod)=1
                  nod = ledge(6,n)
                  icontact(nod)=1
               END IF
            END DO
         END IF
C     
         IF(ibc/=0) THEN
            ibcm = ibc / 8
            ibcs = ibc - 8 * ibcm
C     Boundary cond.
            IF(ibcs>0) THEN
               DO i = 1, nb
                  n = nint(bufr(1,i))
                  nod = ledge(5,n)
                  CALL ibcoff(ibcs,icodt(nod))
                  nod = ledge(6,n)
                  CALL ibcoff(ibcs,icodt(nod))
               END DO
            END IF
         END IF
 
      RETURN
      END