init_th_group.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	init_th_group (gr, igr, nelem, ngrth, iparg, ipart, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring)

Function/Subroutine Documentation

init_th_group()

subroutine init_th_group	(	integer, dimension(*)	gr,
		integer, dimension(*)	igr,
		integer	nelem,
		integer	ngrth,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(lipart1,*)	ipart,
		type (group_), dimension(ngrbric), target	igrbric,
		type (group_), dimension(ngrquad), target	igrquad,
		type (group_), dimension(ngrshel), target	igrsh4n,
		type (group_), dimension(ngrsh3n), target	igrsh3n,
		type (group_), dimension(ngrtrus), target	igrtruss,
		type (group_), dimension(ngrbeam), target	igrbeam,
		type (group_), dimension(ngrspri), target	igrspring )

Definition at line 30 of file init_th_group.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE groupdef_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      "com04_c.inc"
#include      "com01_c.inc"
#include      "param_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IGR(*),GR(*),NELEM,NGRTH,
     .        IPARG(NPARG,*),IPART(LIPART1,*)
C-----------------------------------------------
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRBRIC) :: IGRBRIC
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRQUAD) :: IGRQUAD
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRSHEL) :: IGRSH4N
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRSH3N) :: IGRSH3N
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRTRUS) :: IGRTRUSS
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRBEAM) :: IGRBEAM
      TYPE (GROUP_)  , TARGET, DIMENSION(NGRSPRI) :: IGRSPRING
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,ID,NN,NVAR,ITYP,CPT,GRTMP,IGRTMP(NGRTH+NELEM),
     .       IGR1,FLAG,OFFSET,NG,CPT1,IGRELE,NENTITY
      INTEGER :: NEL,NFT
      INTEGER, DIMENSION(:), POINTER :: ELEM
C-----------------------------------------------
      cpt = 1
      igrtmp = 0
      offset = 0
      cpt1 = 0
      DO k=npart+1,npart+nthpart
        i = ipart(1,k)
        cpt1 = cpt1 + 1
!---
        offset = 0
        igrele = ipart(1,k)
        ityp   = ipart(2,k)
        id     = ipart(4,k)
        nentity = 0
!
        IF (ityp == 1) THEN  ! brick group of thpart
          nentity = igrbric(igrele)%NENTITY
          elem   => igrbric(igrele)%ENTITY
        ELSEIF (ityp == 2) THEN  ! quad group of thpart
          offset = offset + numels
          nentity = igrquad(igrele)%NENTITY
          elem   => igrquad(igrele)%ENTITY
        ELSEIF (ityp == 3) THEN  ! sh4n group of thpart
          offset = offset + numelq
          nentity = igrsh4n(igrele)%NENTITY
          elem   => igrsh4n(igrele)%ENTITY
        ELSEIF (ityp == 4) THEN  ! truss group of thpart
          offset = offset + numelc
          nentity = igrtruss(igrele)%NENTITY
          elem   => igrtruss(igrele)%ENTITY
        ELSEIF (ityp == 5) THEN  ! beam group of thpart
          offset = offset + numelt
          nentity = igrbeam(igrele)%NENTITY
          elem   => igrbeam(igrele)%ENTITY
        ELSEIF (ityp == 6) THEN  ! spring group of thpart
          offset = offset + numelp
          nentity = igrspring(igrele)%NENTITY
          elem   => igrspring(igrele)%ENTITY
        ELSEIF (ityp == 7) THEN  ! SH3N group of thpart
          offset = offset + numelr
          nentity = igrsh3n(igrele)%NENTITY
          elem   => igrsh3n(igrele)%ENTITY
        ENDIF ! IF (ITYP == 1)
!---
        DO j=1,nentity
          igrtmp(cpt) = elem(j)+offset
          gr(cpt) = cpt1
          igr(elem(j)+offset) = igr(elem(j)+offset) + 1
          cpt = cpt + 1
        ENDDO ! DO J=1,NENTITY
      ENDDO ! DO K=NPART+1,NPART+NTHPART
!
      DO i=1,cpt-1
        DO j=i,cpt-1
          IF (igrtmp(i) > igrtmp(j)) THEN
            grtmp = gr(j)
            gr(j) = gr(i)
            gr(i) = grtmp
            grtmp = igrtmp(j)
            igrtmp(j)= igrtmp(i)
            igrtmp(i) = grtmp 
          ENDIF
        ENDDO
      ENDDO
!
      igrtmp = 0
      DO i = 1,nelem
        igrtmp(i) = igr(i)
      ENDDO
!
      flag = 0
      IF (igr(1) == 0) THEN
        igr(1) = 1
      ELSE
        igr(2) = 1 + igr(1) 
        igr(1) = 1
        flag = 1
      ENDIF
!
      DO i = 2,nelem
        IF (igr(i) == 0) THEN
          IF (flag == 0) THEN
            igr(i) = igr(i-1)
          ELSEIF (flag == 1) THEN
            igr(i) = igr(i)
            flag = 0
          ENDIF
        ELSE
          IF (flag == 0) THEN
            igr(i) =  igr(i-1)
            igr(i+1) = igr(i) + igrtmp(i)
          ELSEIF (flag == 1) THEN
            igr(i) =  igr(i)
            igr(i+1) = igr(i) + igrtmp(i)
          ENDIF
          flag = 1
        ENDIF
      ENDDO
!
      DO ng=1,ngroup
        nel     = iparg(2,ng)
        nft     = iparg(3,ng)
        ityp    = iparg(5,ng)
        IF (ityp == 1) offset = 0
        IF (ityp == 2) offset = numels
        IF (ityp == 3) offset = numels + numelq
        IF (ityp == 4) offset = numels + numelq + numelc
        IF (ityp == 5) offset = numels + numelq + numelc
     .                           + numelt
        IF (ityp == 6) offset = numels + numelq + numelc
     .                           + numelt + numelp
        IF (ityp == 7) offset = numels + numelq + numelc
     .                           + numelt + numelp + numelr
        DO j=nft+offset+1,nft+offset+nel
          IF (igr(j) /= igr(j+1)) THEN
            iparg(51,ng) = 1
          ENDIF
        ENDDO
      ENDDO
!---
      RETURN