create_line_from_surface_all.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	create_line_from_surface_all (clause)

Function/Subroutine Documentation

create_line_from_surface_all()

subroutine create_line_from_surface_all

(

type (set_)

clause

)

Definition at line 29 of file create_line_from_surface_all.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE setdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER OPT_A,SET_ID,ELTYP
      TYPE (SET_) :: CLAUSE
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,J1,J2,SIZEMAX,NSEG,IEXT,NSEG_EDGE_EXT,
     .        NSEG_EDGE_ALL,NSEG_SURF,LINE_NENTITY
      INTEGER IWORK(70000),IPERM(4)
!
      DATA iperm /2,3,4,1/
!
      INTEGER , DIMENSION(:),ALLOCATABLE :: INDEX,IW1,IW2,IW5,IW6
      INTEGER , DIMENSION(:,:),ALLOCATABLE :: ITRI,LINE_ORD
C=======================================================================
      sizemax = clause%NB_LINE_SEG +  4*clause%NB_SURF_SEG
 
      IF (sizemax == 0) RETURN
 
!
      line_nentity = 4 ! NOD1, NOD2, ELTYP, ELEM
      ALLOCATE(line_ord(line_nentity,sizemax))
      ALLOCATE(itri(3,sizemax))
      ALLOCATE(index(2*sizemax))
!
      ALLOCATE(iw1(4*sizemax))
      ALLOCATE(iw2(4*sizemax))
      ALLOCATE(iw5(4*sizemax))
      ALLOCATE(iw6(4*sizemax))
!------------------
      ! NSEG of lines  initialization
      nseg = clause%NB_LINE_SEG  ! lines from 1D_element
!     Fill in LINE_ORD array the already stored line from 1D_element
      DO i=1,nseg
        line_ord(1,i) = clause%LINE_NODES(i,1)
        line_ord(2,i) = clause%LINE_NODES(i,2)
        line_ord(3,i) = clause%LINE_ELTYP(i)
        line_ord(4,i) = clause%LINE_ELEM(i)
      ENDDO
!
!     extract lines from furfaces
!
      nseg_surf = clause%NB_SURF_SEG
      IF (nseg_surf > 0) THEN
!***********************************
!***********************************
      ! -- ALL -- edges form SURFACE
!***********************************
!***********************************
        nseg_edge_all = 0
!---
        k=0
        iw1 = 0
        iw2 = 0
        iw5 = 0
        iw6 = 0
        DO i = 1,nseg_surf
          DO j1=1,4
            j2=iperm(j1)
            IF (clause%SURF_NODES(i,j2) /= 0 .AND.
     .          clause%SURF_NODES(i,j1) > clause%SURF_NODES(i,j2)) THEN
              k=k+1
              iw1(k)=clause%SURF_NODES(i,j2)
              iw2(k)=clause%SURF_NODES(i,j1)
              iw5(k)=clause%SURF_ELTYP(i)
              iw6(k)=clause%SURF_ELEM(i)
            ELSEIF (clause%SURF_NODES(i,j1) /= 0 .AND.
     .              clause%SURF_NODES(i,j1) < clause%SURF_NODES(i,j2)) THEN
              k=k+1
              iw1(k)=clause%SURF_NODES(i,j1)
              iw2(k)=clause%SURF_NODES(i,j2)
              iw5(k)=clause%SURF_ELTYP(i)
              iw6(k)=clause%SURF_ELEM(i)
            ENDIF
          ENDDO
        ENDDO ! DO I = 1,NSEG_SURF
!
        nseg_edge_all = k
C-----------------------------------------------
        index = 0
        iwork(1:70000) = 0
        CALL my_orders( 0,iwork,iw1,index,k,1)
        iwork(1:70000) = 0
        CALL my_orders(10,iwork,iw2,index,k,1)
!---
        IF (nseg_edge_all > 0) THEN
C-----------------------------------------------
C         REMOVE DOUBLE SEGMENTS
C-----------------------------------------------
          nseg = nseg + 1
          line_ord(1,nseg) = iw1(index(1))
          line_ord(2,nseg) = iw2(index(1))
          line_ord(3,nseg) = iw5(index(1))
          line_ord(4,nseg) = 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
              line_ord(1,nseg) = iw1(index(i))
              line_ord(2,nseg) = iw2(index(i))
              line_ord(3,nseg) = iw5(index(i))
              line_ord(4,nseg) = iw6(index(i))
            ENDIF
          ENDDO
        ENDIF ! IF (NSEG_EDGE_ALL > 0)
      ENDIF ! IF (NSEG_SURF > 0)
!------------------------------------------
!------------------------------------------
!     ORDER LINES and LINE CLAUSE FILLING
!------------------------------------------
!------------------------------------------
      index = 0
      iwork(1:70000) = 0
      DO i=1,nseg
        index(i)=i
        itri(1,i) = line_ord(1,i)
        itri(2,i) = line_ord(2,i)
        itri(3,i) = line_ord(4,i) ! elem_id
      ENDDO
      CALL my_orders(0,iwork,itri,index,nseg,3)
!
      ! reallocation of the line CLAUSE at the right dimension and final fill
!
      IF (ALLOCATED(clause%LINE_NODES)) DEALLOCATE(clause%LINE_NODES)
      IF (ALLOCATED(clause%LINE_ELTYP)) DEALLOCATE(clause%LINE_ELTYP)
      IF (ALLOCATED(clause%LINE_ELEM))  DEALLOCATE(clause%LINE_ELEM)
!
      clause%NB_LINE_SEG = nseg
      CALL my_alloc(clause%LINE_NODES,nseg,2)
      CALL my_alloc(clause%LINE_ELTYP,nseg)
      CALL my_alloc(clause%LINE_ELEM,nseg)
!
      DO i=1,nseg
        clause%LINE_NODES(i,1) = line_ord(1,index(i))
        clause%LINE_NODES(i,2) = line_ord(2,index(i))
        clause%LINE_ELTYP(i)   = line_ord(3,index(i))
        clause%LINE_ELEM(i)    = line_ord(4,index(i))
      ENDDO
!---
      IF (ALLOCATED(line_ord))  DEALLOCATE(line_ord)
      IF (ALLOCATED(itri))  DEALLOCATE(itri)
      IF (ALLOCATED(index)) DEALLOCATE(index)
      IF (ALLOCATED(iw1))   DEALLOCATE(iw1)
      IF (ALLOCATED(iw2))   DEALLOCATE(iw2)
      IF (ALLOCATED(iw5))   DEALLOCATE(iw5)
      IF (ALLOCATED(iw6))   DEALLOCATE(iw6)
C-----------
      RETURN