dseccnt.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	dseccnt (nesct, nerwl, nesbw, nstrf, rwbuf, nprw, nnwl, ixs)

Function/Subroutine Documentation

dseccnt()

subroutine dseccnt	(	integer	nesct,
		integer	nerwl,
		integer	nesbw,
		integer, dimension(*)	nstrf,
			rwbuf,
		integer, dimension(*)	nprw,
		integer	nnwl,
		integer, dimension(nixs,*)	ixs )

Definition at line 30 of file dseccnt.F.

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      "param_c.inc"
#include      "task_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real
     .  rwbuf(nrwlp,*)
      INTEGER NESCT,NERWL,NESBW,NNWL,
     .        NSTRF(*),NPRW(*),IXS(NIXS,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER J, I, K, K1, N, NSEG, N1, N2, N3, N4,NSEGC, NSEGTG,
     .    ITYP, KK,ITMP, K0, K5, K9
      my_real
     .   xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3,
     .   xx4, yy4, zz4, d13, xxc, yyc, zzc
      INTEGER NSEGS, POWER2(8),IPACK,
     .         II(8), N5, N6, N7, N8, K3
      DATA power2/1,2,4,8,16,32,64,128/
C-----------------------------------------------
      IF (nsect>0) THEN
        k0 = nstrf(25)
        DO i=1,nsect
          k5=k0+30+nstrf(k0+14)+nstrf(k0+6)
     1         + 2*nstrf(k0+7) +nstrf(k0+8)*2
          nsegc = nstrf(k0+9)
          DO j=1,nsegc
            kk = k5+2*(j-1)+1
            IF(nstrf(kk)/=0) nesct = nesct + 1
          ENDDO
          k9=k5+2*nstrf(k0+9) +2*nstrf(k0+10)
     1         +2*nstrf(k0+11)+2*nstrf(k0+12)
          nsegtg = nstrf(k0+13)
          DO j=1,nsegtg
            kk = k9+2*(j-1)+1
            IF(nstrf(kk)/=0) nesct = nesct + 1
          ENDDO
          k3=k0+30+nstrf(k0+14)+nstrf(k0+6)
          nsegs=nstrf(k0+7)
 
          IF(nsegs/=0) nesct = nesct + 1
 
          DO j=1,nsegs
            kk=k3+2*(j-1)
            ipack=nstrf(kk+1)
            IF(ipack/=0)THEN
              n =nstrf(kk)
              ii(1)=ixs(2,n)
              ii(2)=ixs(3,n)
              ii(3)=ixs(4,n)
              ii(4)=ixs(5,n)
              ii(5)=ixs(6,n)
              ii(6)=ixs(7,n)
              ii(7)=ixs(8,n)
              ii(8)=ixs(9,n)
              IF(     ii(2)==ii(1).AND.ii(4)==ii(3)
     .           .AND.ii(8)==ii(5).AND.ii(7)==ii(6))THEN
C tetra4, tetra10
                n1=mod(ipack/power2(1),2)
                n2=mod(ipack/power2(3),2)
                n3=mod(ipack/power2(5),2)
                n4=mod(ipack/power2(6),2)
                IF(n1/=0.AND.n2/=0.AND.n3/=0)
     .             nesct = nesct + 1
                IF(n1/=0.AND.n2/=0.AND.n4/=0)
     .             nesct = nesct + 1
                IF(n2/=0.AND.n3/=0.AND.n4/=0)
     .             nesct = nesct + 1
                IF(n3/=0.AND.n1/=0.AND.n4/=0)
     .             nesct = nesct + 1
              ELSE
C brick, shell16, brick20
                n1=mod(ipack/power2(1),2)
                n2=mod(ipack/power2(2),2)
                n3=mod(ipack/power2(3),2)
                n4=mod(ipack/power2(4),2)
                n5=mod(ipack/power2(5),2)
                n6=mod(ipack/power2(6),2)
                n7=mod(ipack/power2(7),2)
                n8=mod(ipack/power2(8),2)
                IF(n1/=0.AND.n2/=0.AND.n3/=0.AND.n4/=0)
     .             nesct = nesct + 1
                IF(n5/=0.AND.n6/=0.AND.n7/=0.AND.n8/=0)
     .             nesct = nesct + 1
                IF(n1/=0.AND.n5/=0.AND.n6/=0.AND.n2/=0)
     .             nesct = nesct + 1
                IF(n4/=0.AND.n8/=0.AND.n7/=0.AND.n3/=0)
     .             nesct = nesct + 1
                IF(n1/=0.AND.n4/=0.AND.n8/=0.AND.n5/=0)
     .             nesct = nesct + 1
                IF(n2/=0.AND.n3/=0.AND.n7/=0.AND.n6/=0)
     .             nesct = nesct + 1
              END IF
            END IF
          END DO
          k0=nstrf(k0+24)
        ENDDO
      ENDIF
      IF (nspmd > 1 .AND. nsect>0) THEN
        CALL spmd_glob_isum9(nesct,1)
        IF (ispmd/=0) GOTO 100
      ENDIF
C
      k=1
      DO n=1,nrwall
         n2=n +nrwall
         n3=n2+nrwall
         n4=n3+nrwall
         ityp= nprw(n4)
 
         IF(iabs(ityp)==1)THEN
            nerwl = nerwl + 1 + 1
            nnwl = nnwl + 4
         ELSEIF(ityp==2)THEN
            nerwl = nerwl + 24 + 1
            nnwl = nnwl + 48
         ELSEIF(ityp==3)THEN
            nerwl = nerwl + 216 + 1
            nnwl = nnwl + 294
         ELSEIF(ityp==4)THEN
            nerwl = nerwl + 1 + 1
            nnwl = nnwl + 4
         ENDIF
         k=k+nprw(n)
         IF(nprw(n4)==-1)k=k+nint(rwbuf(8,n))
      ENDDO
C
      nesbw = nesct + nerwl
C
 100  CONTINUE
      RETURN