lecflsw.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/.
!||====================================================================
!||    lecflsw       ../engine/source/fluid/lecflsw.F
!||--- called by ------------------------------------------------------
!||    lectur        ../engine/source/input/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg        ../engine/source/output/message/message.F
!||    arret         ../engine/source/system/arret.F
!||    nintrn        ../engine/source/fluid/nintrn.F
!||--- uses       -----------------------------------------------------
!||    message_mod   ../engine/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE lecflsw (NSFLSW,NTFLSW,NEFLSW,NNFLSW,CRFLSW,
     .                    X,IXS,IPARG,ITMP)
      USE message_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      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NSFLSW, NTFLSW
      INTEGER NEFLSW(*), NNFLSW(8,*), IXS(NIXS,*), IPARG(NPARG,*), ITMP(*)
      my_real crflsw(6,*), x(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IL, I, IS, NEL, J, K, IE, II, NG, ITY, LFT, LLT, NFT, NB1,
     .   n, i2, i1, ne, n1, n2, n3, n4
      my_real
     .   crx, cry, crz, surs, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4,
     .   y4, z4, sfx, sfy, sfz, sfm, surv
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER NINTRN
C-----------------------------------------------
      il = 0
      WRITE (iout, 1000)
      DO 200 i = 1, nsflsw
C
C     LECTURE DU NUMERO DE LA SECTION ET DU NOMBRE DE FACES
C
        READ (iin, '(2I5,3F10.0)') is, nel, crx, cry, crz
C
C
C     LECTURE DES FACES PAR SECTION
C
        neflsw(i) = nel
        crflsw(1,i) = crx
        crflsw(2,i) = cry
        crflsw(3,i) = crz
        DO 100 j = 1, nel
          il = il + 1
          READ(iin, '(6I5)') nnflsw(7,il),(nnflsw(k,il),k=2,6)
  100   CONTINUE
  200 CONTINUE
C
C     TEST SI LE NOMBRE TOTALE DE FACES EST EGALE A NTFLSW
C
      IF (il /= ntflsw) THEN
        CALL ancmsg(msgid=16,anmode=aninfo,
     .              i1=il,i2=ntflsw)
        CALL arret(2)
      END IF
C
C     CALCUL DE LA NUMEROTATION INTERNE DES ELEMENTS ET L'ADRESSE
C     DANS LE BUFFER D'ELEMENTS
C       IL               :  NUMERO LOCALE DE LA FACE ET DE L'ELEMENT
C       IE               :  NUMERO EXTERNE DE L'ELEMENT
C       NEL=NNFLSW(1,IL) :  NOMBRE D'ELEMENTS DANS LE GROUPE D'ELEMENTS
C       IB2=NNFLSW(7,IL) :  ADRESSE DE LA PRESSION (ECRASE NUMERO EXTERNE)
C       IB3=NNFLSW(8,IL) :  ADRESSE DE L'ENERGIE
C       ITMP(II) = IL    :  NUMERATION LOCALE DES ELEMENTS DES SECTIONS
C
      DO 300 i = 1, numels
        itmp(i) = 0
  300 CONTINUE
C
      DO 310 il = 1, ntflsw
        ie = nnflsw(7,il)
        ii = nintrn(ie,ixs,11,numels)
        itmp(ii) = il
        IF (nnflsw(6,il) == 0) nnflsw(6,il) = 4
  310 CONTINUE
C
      DO 350 ng=1,ngroup
        ity = iparg(5,ng)
        IF(ity>1) GO TO 350
        lft = 1
        llt = iparg(2,ng)
        nft = iparg(3,ng)
        nb1 = iparg(4,ng)
        DO 330 i = lft,llt
          n = i+nft
          il = itmp(n)
          IF (il > 0) THEN
            nnflsw(7,il) = nb1 +   llt + 6*i - 6
            nnflsw(8,il) = nb1 + 7*llt +   i - 1
            nnflsw(1,il) = llt
          END IF
  330   CONTINUE
  350 CONTINUE
C
C     CALCUL DES SURFACES ET DE LA NORMALE PAR SECTION
C
      il = 0
      i2 = 0
      DO 500 is = 1, nsflsw
        surs = 0.
        nel = neflsw(is)
        i1  = i2 + 1
        i2  = i2 + nel
        DO 400 i = i1, i2
            ne = nnflsw(1,i)
            n1 = nnflsw(2,i)
            n2 = nnflsw(3,i)
            n3 = nnflsw(4,i)
            n4 = nnflsw(5,i)
C
            x1 = x(1,n1)
            y1 = x(2,n1)
            z1 = x(3,n1)
            x2 = x(1,n2)
            y2 = x(2,n2)
            z2 = x(3,n2)
            x3 = x(1,n3)
            y3 = x(2,n3)
            z3 = x(3,n3)
            x4 = x(1,n4)
            y4 = x(2,n4)
            z4 = x(3,n4)
C
            sfx = half*((y3-y1)*(z4-z2)-
     1                   (z3-z1)*(y4-y2))
            sfy = half*((z3-z1)*(x4-x2)-
     1                   (x3-x1)*(z4-z2))
            sfz = half*((x3-x1)*(y4-y2)-
     1                   (y3-y1)*(x4-x2))
            sfm = sqrt(sfx*sfx+sfy*sfy+sfz*sfz)
C
            crflsw(4,is) = crflsw(4,is) + sfx
            crflsw(5,is) = crflsw(5,is) + sfy
            crflsw(6,is) = crflsw(6,is) + sfz
            surs         = surs + sfm
C
  400     CONTINUE
C
          surv = sqrt(crflsw(4,is)**2+crflsw(5,is)**2+crflsw(6,is)**2)
          crflsw(4,is) = crflsw(4,is)/surv
          crflsw(5,is) = crflsw(5,is)/surv
          crflsw(6,is) = crflsw(6,is)/surv
C
        WRITE (iout, 1100) is, nel, (crflsw(k,is),k=1,6),surv,surs
        WRITE (iout, 1200)
     1              (j,(nnflsw(k,il-nel+j),k=1,8),j=1,nel,nel-1)
  500 CONTINUE
C
 1000 FORMAT (///' FLUX AND SWIRL CALCULATION'/
     1           ' --------------------------'/)
 1100 FORMAT (/
     1  ' SET NUMBER . . . . . . . . . . ',i5/
     1  '    NUMBER OF ELEMENTS. . . . . ',i5/
     1  '    SWIRL CENTER. . . . . . . . ',3e12.4/
     1  '    SWIRL AXIS. . . . . . . . . ',3e12.4/
     1  '    VECTORIAL TOTAL SURFACE . . ',e12.4 /
     1  '    SCALAR TOTAL SURFACE. . . . ',e12.4 /
     1   1h ,16hfirst/last numb.,6hi.e.n.,4x,6hnode-1,4x,6hnode-2,4x,
     2                      6hnode-3,4x,6hnode-4,4x,6h ndiv    )
 1200 FORMAT (2h  ,10i10)
      RETURN
      END