linedge.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	linedge (nseg0, nseg, buftmp, slin_nodes, key, flag, slin_eltyp, slin_elem, line_nseg0)

Function/Subroutine Documentation

linedge()

subroutine linedge	(	integer	nseg0,
		integer	nseg,
		integer, dimension(6,*)	buftmp,
		integer, dimension(line_nseg0,*)	slin_nodes,
		character(len=ncharkey)	key,
		integer	flag,
		integer, dimension(*)	slin_eltyp,
		integer, dimension(*)	slin_elem,
		integer	line_nseg0 )

Definition at line 30 of file linedge.F.

        USE names_and_titles_mod , ONLY : ncharkey
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-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NSEG0,NSEG,FLAG,LINE_NSEG0
      INTEGER BUFTMP(6,*),SLIN_NODES(LINE_NSEG0,*),SLIN_ELTYP(*),
     .        SLIN_ELEM(*)
      CHARACTER(LEN=NCHARKEY) :: KEY
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,J1,J2,IPERM(4)
C     INTEGER IW1(4*NSEG0),IW2(4*NSEG0),IW5(4*NSEG0),IW6(4*NSEG0),
C    .        INDEX(8*NSEG0),IWORK(70000), IPERM(4)
      integer, dimension(:), allocatable :: IW1,IW2,IW5,IW6,INDEX,IWORK
      DATA iperm /2,3,4,1/
C=======================================================================
      ALLOCATE(iw1(4*nseg0), iw2(4*nseg0), iw5(4*nseg0),iw6(4*nseg0), index(8*nseg0))
      ALLOCATE(iwork(70000))
      k=0
      iw1 = 0
      iw2 = 0
      iw5 = 0
      iw6 = 0
      index = 0
      DO i = 1,nseg0
        DO j1=1,4
          j2=iperm(j1)
          IF(buftmp(j2,i)/=0.AND.
     .       buftmp(j1,i)>buftmp(j2,i))THEN
            k=k+1
            iw1(k)=buftmp(j2,i)
            iw2(k)=buftmp(j1,i)
            iw5(k)=buftmp(5,i)
            iw6(k)=buftmp(6,i)
          ELSEIF(buftmp(j1,i)/=0.AND.
     .           buftmp(j1,i)<buftmp(j2,i))THEN
            k=k+1
            iw1(k)=buftmp(j1,i)
            iw2(k)=buftmp(j2,i)
            iw5(k)=buftmp(5,i)
            iw6(k)=buftmp(6,i)
          ENDIF
        ENDDO
      ENDDO
C-----------------------------------------------
      CALL my_orders( 0,iwork,iw1,index,k,1)  
      CALL my_orders(10,iwork,iw2,index,k,1)  
C-----------------------------------------------
      IF (key(1:4) == 'SURF') THEN
C-----------------------------------------------
C REMOVAL OF DOUBLE SEGMENTS
C-----------------------------------------------
        nseg=1
        IF (flag == 0) THEN
          DO i=2,k
            IF(iw1(index(i-1))/=iw1(index(i)).OR.
     .         iw2(index(i-1))/=iw2(index(i))) nseg=nseg+1
          ENDDO
        ELSEIF (flag == 1) THEN
          slin_nodes(1,1) = iw1(index(1))
          slin_nodes(1,2) = iw2(index(1))
          slin_eltyp(1)   = iw5(index(1))
          slin_elem(1)    = iw6(index(1))
          DO i=2,k
            IF(iw1(index(i-1))/=iw1(index(i)).OR.
     .         iw2(index(i-1))/=iw2(index(i)))THEN
              nseg=nseg+1
              slin_nodes(nseg,1) = iw1(index(i))
              slin_nodes(nseg,2) = iw2(index(i))
              slin_eltyp(nseg)   = iw5(index(i))
              slin_elem(nseg)    = iw6(index(i))
            ENDIF
          ENDDO
        ENDIF ! IF (FLAG == 0)
      ELSEIF (key(1:4) == 'EDGE') THEN
C-----------------------------------------------
C REMOVAL OF INTERNAL SEGMENTS (EXCEPT BORDERS)
C-----------------------------------------------
        nseg=0
        IF (flag == 0) THEN
          IF(iw1(index(1))/=iw1(index(2)).OR.
     .       iw2(index(1))/=iw2(index(2))) nseg=1
          DO i=2,k-1
            IF((iw1(index(i-1))/=iw1(index(i)).OR.
     .          iw2(index(i-1))/=iw2(index(i))).AND.
     .         (iw1(index(i+1))/=iw1(index(i)).OR.
     .          iw2(index(i+1))/=iw2(index(i)))) nseg=nseg+1
          ENDDO
          IF(iw1(index(k-1))/=iw1(index(k)).OR.
     .       iw2(index(k-1))/=iw2(index(k))) nseg=nseg+1                    
C
        ELSEIF (flag == 1) THEN
          IF(iw1(index(1))/=iw1(index(2)).OR.
     .       iw2(index(1))/=iw2(index(2)))THEN
             nseg=1                    
             slin_nodes(nseg,1) = iw1(index(1))
             slin_nodes(nseg,2) = iw2(index(1))
             slin_eltyp(nseg)   = iw5(index(1))
             slin_elem(nseg)    = iw6(index(1))
          ENDIF
          DO i=2,k-1
            IF((iw1(index(i-1))/=iw1(index(i)).OR.
     .          iw2(index(i-1))/=iw2(index(i))).AND.
     .         (iw1(index(i+1))/=iw1(index(i)).OR.
     .          iw2(index(i+1))/=iw2(index(i))))THEN
              nseg=nseg+1
              slin_nodes(nseg,1) = iw1(index(i))
              slin_nodes(nseg,2) = iw2(index(i))
              slin_eltyp(nseg)   = iw5(index(i))
              slin_elem(nseg)    = iw6(index(i))
            ENDIF
          ENDDO
          IF(iw1(index(k-1))/=iw1(index(k)).OR.
     .       iw2(index(k-1))/=iw2(index(k)))THEN
            nseg=nseg+1                    
            slin_nodes(nseg,1) = iw1(index(k))
            slin_nodes(nseg,2) = iw2(index(k))
            slin_eltyp(nseg)   = iw5(index(k))
            slin_elem(nseg)    = iw6(index(k))
          ENDIF ! IF (FLAG == 0)
        ENDIF ! IF (KEY(1:4) == 'SURF')
C-----------
      ENDIF
C-----------
      DEALLOCATE(iw1 ,iw2, iw5,iw6, index,iwork)
 
      RETURN