lecflsw.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	lecflsw (nsflsw, ntflsw, neflsw, nnflsw, crflsw, x, ixs, iparg, itmp)

Function/Subroutine Documentation

lecflsw()

subroutine lecflsw	(	integer	nsflsw,
		integer	ntflsw,
		integer, dimension(*)	neflsw,
		integer, dimension(8,*)	nnflsw,
			crflsw,
			x,
		integer, dimension(nixs,*)	ixs,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(*)	itmp )

Definition at line 35 of file lecflsw.F.

      USE message_mod
      use element_mod , only : nixs
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     READ SECTION NUMBER AND NUMBER OF FACES
C
        READ (iin, '(2I5,3F10.0)') is, nel, crx, cry, crz
C
C
C     READ FACES PER 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 IF TOTAL NUMBER OF FACES EQUALS NTFLSW
C
      IF (il /= ntflsw) THEN
        CALL ancmsg(msgid=16,anmode=aninfo,
     .              i1=il,i2=ntflsw)
        CALL arret(2)
      END IF
C
C     CALCULATE INTERNAL NUMBERING OF ELEMENTS AND ADDRESS
C     IN THE ELEMENTS BUFFER
C       IL               :  LOCAL NUMBER OF THE FACE AND ELEMENT
C       IE               :  EXTERNAL NUMBER OF THE ELEMENT
C       NEL=NNFLSW(1,IL) :  NUMBER OF ELEMENTS IN THE ELEMENT GROUP
C       IB2=NNFLSW(7,IL) :  ADDRESS OF THE PRESSURE (OVERWRITES EXTERNAL NUMBER)
C       IB3=NNFLSW(8,IL) :  ADDRESS OF THE ENERGY
C       ITMP(II) = IL    :  LOCAL NUMBERING OF SECTION ELEMENTS
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     CALCULATE SURFACES AND NORMALS PER 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