asspar3.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/.
!||====================================================================
!||    asspar3      ../engine/source/assembly/asspar3.F
!||--- called by ------------------------------------------------------
!||    resol        ../engine/source/engine/resol.F
!||--- calls      -----------------------------------------------------
!||    my_barrier   ../engine/source/system/machine.F
!||====================================================================
      SUBROUTINE asspar3(
     2   A          ,AR         ,ITASK                 ,NODFT      ,
     3   NODLT      ,STIFN      ,STIFR      ,ITAB      ,FSKY       ,
     4   FSKYV      ,ISKY       ,INDSKY     ,FSKYI     ,
     5   ADSKYI     ,PARTFT     ,PARTLT     ,PARTSAV   ,MS         ,
     6   FTHE       ,FTHESKY    ,FTHESKYI   ,GREFT     ,GRELT      ,
     7   GRESAV     ,ITHERM_FE  ,INTHEAT    )
C----6---------------------------------------------------------------7---------8
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      "com04_c.inc"
#include      "com08_c.inc"
#include      "parit_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
        integer maxbloc
        parameter (maxbloc=1000)
        common/tmparit/nbloc,adbloc(0:maxbloc),nbcol(0:maxbloc),
     .         nbdone(maxbloc),ideb(parasiz),ifin(parasiz)
        integer nbloc,adbloc,nbcol,nbdone,ideb,ifin
C-----------------------------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ,INTENT(IN) :: ITHERM_FE
        INTEGER ,INTENT(IN) :: INTHEAT
C     REAL
        my_real
     .     a(3,*)   ,ar(3,*), stifn(*), stifr(*),fskyv(lsky,8),
     .     fskyi(lskyi,4),partsav(*),fsky(8,lsky), ms(*),
     .     fthe(*), fthesky(*),ftheskyi(lskyi),gresav(*)
        INTEGER ITASK,NODFT,NODLT,PARTFT,PARTLT,GREFT,GRELT
        INTEGER ISKY(*),INDSKY(0:*),ADSKYI(0:*),ITAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,L,N,KK,JJ1,JJ2,NN,KM,NUM7,LL,
     .          niskyft,niskylt, ldone,idone,nc,nl,ift,ilt,kft,klt,
     .          i0,ibar,kkk,nct
        my_real
     .          ff, fskyt(nisky), ftheskyt(nisky)
        COMMON /assp2/ ldone, idone, ibar
C-----------------------------------------------
        IF(nthread*nisky+numnod+2>lenwa)THEN
          WRITE(iout,*) ' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
          WRITE(istdo,*)' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
          tstop=zero
          RETURN
        ENDIF
        IF(nisky>lskyi)THEN
          WRITE(iout,*) ' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
          WRITE(istdo,*)' **ERROR** : MEMORY PROBLEM IN PARITH OPTION'
          tstop=zero
          RETURN
        ENDIF
        niskyft   = 1+itask*nisky/ nthread
        niskylt   = (itask+1)*nisky/nthread
c      print *,' nisky=',nisky,' nodlt=',nodlt
C
        DO n=nodft,nodlt
          adskyi(n) = 0
        ENDDO
        adskyi(numnod+1) = 0
C
        idone = 0
        ldone = 0
        ibar  = 0
        DO  l=1,nbloc
          nbdone(l) = -1
        ENDDO
        CALL my_barrier
C-----------------------------------------------
C     FORCES D'INTERFACES
C-----------------------------------------------
#include "lockon.inc"
        IF(idone/=0)THEN
#include "lockoff.inc"
        ELSE
          idone = 1
#include "lockoff.inc"
C
          DO i=1,nisky
            n = isky(i) +1
            adskyi(n) = adskyi(n) + 1
          ENDDO
C-----------------------------------------------
C   CALCUL DES ADRESSES DU VECTEUR SKYLINE
C-----------------------------------------------
          adskyi(0) = 1
          adskyi(1) = 1
          DO n=1,numnod
            nn = n+1
            adskyi(nn) = adskyi(nn) + adskyi(n)
          ENDDO
C-----------------------------------------------
C   TRI DES FORCES EN SKYLINE
C-----------------------------------------------
          DO i=1,nisky
            n = isky(i)
            j  = adskyi(n)
            isky(i)  = j
            adskyi(n) = adskyi(n) + 1
          ENDDO
C
#include "lockon.inc"
          idone = 2
#include "lockoff.inc"
        ENDIF
C-----------------------------------------------
C     FORCES D'ELEMENTS
C-----------------------------------------------
 
        IF(ivector==1) THEN
        ELSE
          DO n = ideb(itask+1), ifin(itask+1)
            nct = indsky(n)-1
            nc = indsky(n+1)-indsky(n)
            IF(itherm_fe == 0 )THEN
              DO k = nct+1, nct+nc-1
                DO kk=nct+2,nct+nc
                  DO ll=1,8
                    IF(fsky(ll,kk)<fsky(ll,k))THEN
                      ff = fsky(ll,kk)
                      fsky(ll,kk) = fsky(ll,k)
                      fsky(ll,k)  = ff
                    ENDIF
                  ENDDO
                ENDDO
              ENDDO
            ELSE
              DO k = nct+1, nct+nc-1
                DO kk=nct+2,nct+nc
                  DO ll=1,8
                    IF(fsky(ll,kk)<fsky(ll,k))THEN
                      ff = fsky(ll,kk)
                      fsky(ll,kk) = fsky(ll,k)
                      fsky(ll,k)  = ff
                    ENDIF
                  ENDDO
                  IF(fthesky(kk)<fthesky(k))THEN
                    ff = fthesky(kk)
                    fthesky(kk) = fthesky(k)
                    fthesky(k)  = ff
                  ENDIF
                ENDDO
              ENDDO
            ENDIF
C
            IF(itherm_fe == 0 ) THEN
              DO k=nct+1, nct+nc
                a(1,n)  = a(1,n)  + max(zero,fsky(1,k))
                a(2,n)  = a(2,n)  + max(zero,fsky(2,k))
                a(3,n)  = a(3,n)  + max(zero,fsky(3,k))
                ar(1,n)  = ar(1,n)  + max(zero,fsky(4,k))
                ar(2,n)  = ar(2,n)  + max(zero,fsky(5,k))
                ar(3,n)  = ar(3,n)  + max(zero,fsky(6,k))
                stifn(n) = stifn(n) + max(zero,fsky(7,k))
                stifr(n) = stifr(n) + max(zero,fsky(8,k))
              ENDDO
              DO k=nct+nc, nct+1,-1
                a(1,n)  = a(1,n)  + min(zero,fsky(1,k))
                a(2,n)  = a(2,n)  + min(zero,fsky(2,k))
                a(3,n)  = a(3,n)  + min(zero,fsky(3,k))
                ar(1,n)  = ar(1,n)  + min(zero,fsky(4,k))
                ar(2,n)  = ar(2,n)  + min(zero,fsky(5,k))
                ar(3,n)  = ar(3,n)  + min(zero,fsky(6,k))
              ENDDO
            ELSE
              DO k=nct+1, nct+nc
                a(1,n)  = a(1,n)  + max(zero,fsky(1,k))
                a(2,n)  = a(2,n)  + max(zero,fsky(2,k))
                a(3,n)  = a(3,n)  + max(zero,fsky(3,k))
                ar(1,n)  = ar(1,n)  + max(zero,fsky(4,k))
                ar(2,n)  = ar(2,n)  + max(zero,fsky(5,k))
                ar(3,n)  = ar(3,n)  + max(zero,fsky(6,k))
                stifn(n) = stifn(n) + max(zero,fsky(7,k))
                stifr(n) = stifr(n) + max(zero,fsky(8,k))
                fthe(n)   = fthe(n) + max(zero,fthesky(k))
              ENDDO
              DO k=nct+nc, nct+1,-1
                a(1,n)  = a(1,n)  + min(zero,fsky(1,k))
                a(2,n)  = a(2,n)  + min(zero,fsky(2,k))
                a(3,n)  = a(3,n)  + min(zero,fsky(3,k))
                ar(1,n)  = ar(1,n)  + min(zero,fsky(4,k))
                ar(2,n)  = ar(2,n)  + min(zero,fsky(5,k))
                ar(3,n)  = ar(3,n)  + min(zero,fsky(6,k))
                fthe(n)   = fthe(n) + min(zero,fthesky(k))
              ENDDO
            ENDIF
C
          ENDDO
        ENDIF
C
        IF(n2d/=0) THEN
          CALL my_barrier
          DO i = nodft, nodlt
            ms(i) = a(1,i)
            a(1,i) = zero
          ENDDO
          CALL my_barrier
        ENDIF
C-----------------------------------------------
C     LE CALL BARRIER EST FAIT SUR TOUS LES PROCES.
C     SI ET SEULEMENT SI LA TACHE IDONE N'EST PAS FAITE
C     QUAND LE PREMIER DES PROCES. ARRIVE ICI
C-----------------------------------------------
#include "lockon.inc"
        IF(idone/=2)ibar = 1
#include "lockoff.inc"
        IF(ibar==1)CALL my_barrier
C-----------------------------------------------
        DO l=1,4
#include "lockon.inc"
          IF(ldone>=l)THEN
#include "lockoff.inc"
          ELSE
            ldone = l
#include "lockoff.inc"
            DO i=1,nisky
              j = isky(i)
              fskyt(j) = fskyi(i,l)
            ENDDO
            DO i=1,nisky
              fskyi(i,l) = fskyt(i)
            ENDDO
C
            IF(intheat > 0 .AND. l == 1) THEN
              DO  i=1,nisky
                j = isky(i)
                ftheskyt(j) = ftheskyi(i)
              ENDDO
              DO  i=1,nisky
                ftheskyi(i) = ftheskyt(i)
              ENDDO
            ENDIF
C
          ENDIF
        ENDDO
C
        CALL my_barrier
C
        DO i=niskyft,niskylt
          isky(i) = 0
        ENDDO
        nisky = 0
C adsKy est decale de 1
C-----------------------------------------------
C     FORCES D'INTERFACES
C-----------------------------------------------
        DO 800 n=nodft,nodlt
          nn = n-1
          jj1 = adskyi(nn)
          jj2 = adskyi(n)-1
C-----------------------------------------------
C       TRI DES FORCES D'INTERFACES
C-----------------------------------------------
          IF(intheat == 0) THEN
            DO 500 k=jj1,jj2-1
              DO 500 kk=k+1,jj2
                DO 500 ll=1,4
                  IF(fskyi(kk,ll)<fskyi(k,ll))THEN
                    ff = fskyi(kk,ll)
                    fskyi(kk,ll) = fskyi(k,ll)
                    fskyi(k,ll)  = ff
                  ENDIF
 500        CONTINUE
C +  la thermique
          ELSE
            DO  k=jj1,jj2-1
              DO  kk=k+1,jj2
                DO  ll=1,4
                  IF(fskyi(kk,ll)<fskyi(k,ll))THEN
                    ff = fskyi(kk,ll)
                    fskyi(kk,ll) = fskyi(k,ll)
                    fskyi(k,ll)  = ff
                  ENDIF
                ENDDO
                IF(ftheskyi(kk) < ftheskyi(k))THEN
                  ff = ftheskyi(kk)
                  ftheskyi(kk) = ftheskyi(k)
                  ftheskyi(k)  = ff
                ENDIF
              ENDDO
            ENDDO
          ENDIF
C-----------------------------------------------
C       ASSEMBLAGE DES FORCES
C-----------------------------------------------
          IF(intheat == 0 ) THEN
            DO k=jj1,jj2
              a(1,n)  = a(1,n)  + max(zero,fskyi(k,1))
              a(2,n)  = a(2,n)  + max(zero,fskyi(k,2))
              a(3,n)  = a(3,n)  + max(zero,fskyi(k,3))
              stifn(n) = stifn(n) + fskyi(k,4)
            ENDDO
            DO k=jj2,jj1,-1
              a(1,n)  = a(1,n)  + min(zero,fskyi(k,1))
              a(2,n)  = a(2,n)  + min(zero,fskyi(k,2))
              a(3,n)  = a(3,n)  + min(zero,fskyi(k,3))
            ENDDO
C + la thermique
          ELSE
            DO k=jj1,jj2
              a(1,n)  = a(1,n)  + max(zero,fskyi(k,1))
              a(2,n)  = a(2,n)  + max(zero,fskyi(k,2))
              a(3,n)  = a(3,n)  + max(zero,fskyi(k,3))
              stifn(n) = stifn(n) + fskyi(k,4)
              fthe(n)  = fthe(n)  + max(zero,ftheskyi(k))
            ENDDO
            DO k=jj2,jj1,-1
              a(1,n)  = a(1,n)  + min(zero,fskyi(k,1))
              a(2,n)  = a(2,n)  + min(zero,fskyi(k,2))
              a(3,n)  = a(3,n)  + min(zero,fskyi(k,3))
              fthe(n)  = fthe(n)  + min(zero,ftheskyi(k))
            ENDDO
          ENDIF
 800    CONTINUE
C-----------------------------------------------
C
C  003      NUM7 = 7*NPART
        num7 = npsav*npart
C
        km = 0
        DO 950 k=1,nthread-1
          km = km + num7
          DO 940 i=partft,partlt
            partsav(i) = partsav(i) + partsav(i+km)
            partsav(i+km) = zero
 940      CONTINUE
 950    CONTINUE
C
        CALL my_barrier
C
        num7 = npsav*ngpe
C
        km = 0
        IF (nthpart > 0) THEN
          DO 970 k=1,nthread-1
            km = km + num7
#include "vectorize.inc"
            DO 960 i=greft,grelt
              gresav(i)    = gresav(i) + gresav(i+km)
              gresav(i+km) = 0.
 960        CONTINUE
 970      CONTINUE
        ENDIF
        CALL my_barrier
C
        RETURN
      END