Sources Esope | Cast3M

impos4
C IMPOS4    SOURCE    CB215821  20/11/25    13:30:17     10792          
      SUBROUTINE IMPOS4
c
c     sous routine pour l'opérateur IMPO option CONT
c     qui donne le contour des contacts à partir de la rigidite
c     active calculée par impos4.eso
c
c
c
c  entree:
c      IPRIG pointeur sur l
c  sortie:
c  MAIL2 = contour des surfaces en contact formé d'elements SEG2
c
c
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL FLAG1
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC SMRIGID
-INC SMCHPOI
      SEGMENT MCTC
c      mctc contient les surface en vis a vis
        INTEGER IPOT1(NNO1)
        INTEGER IPOT2(NNO2)
      ENDSEGMENT
      POINTEUR MCTC1.MCTC,MCTC2.MCTC
c
      SEGMENT LCTC
c       imctc pointe vers les mctc
        INTEGER IMCTC(NBELEM,2)
      ENDSEGMENT
c
      SEGMENT MPLX
c        contient les numero de points qui supportent un composante
c        'lx'
          INTEGER IPLX(NPLX)
      ENDSEGMENT
c
c executable:
      IF ( IDIM .NE. 2 ) THEN
          INTERR(1) = IDIM
          RETURN
      ENDIF
c
      CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU)
      IF (IERR.NE.0) RETURN
c
      SEGACT MCHPOI
      NPLX = 0
      SEGINI MPLX
c       boucle sur les msoupo pour remplir mplx de tous les points
c       supportant une composante nommée 'lx'
      DO 300 I=1,IPCHP(/1)
         MSOUPO = IPCHP(I)
         SEGACT MSOUPO
c        boucle sur les noms de composantes
         DO 200 J=1,NOCOMP(/2)
           IF ( NOCOMP(J) .EQ. 'LX' ) THEN
             IPT1 = IGEOC
             SEGACT IPT1
             NNPLX = NPLX
*             print *, 'nplx=',nplx
             NPLX = NPLX + IPT1.NUM(/2)
             SEGADJ MPLX
c            on remplit mplx
             DO 100 K = 1,IPT1.NUM(/2)
*               print *,'noeud actif',IPT1.NUM(1,K)
               IPLX(NNPLX+K)=IPT1.NUM(1,K)
 100         CONTINUE
             SEGDES IPT1
          ENDIF
 200    CONTINUE
        SEGDES MSOUPO
 300  CONTINUE
      SEGDES MCHPOI
*
*      PRINT *,'nplx=',nplx
*
c
      SEGACT MELEME
c     on attend un maillage d'elements type 22 a 4 noeuds
      IF (ITYPEL .NE. 22 .OR. NUM(/1) .NE. 4) THEN
        CALL ERREUR(26)
      ENDIF
c
      NBELEM = NUM(/2)
      NB = NBELEM
*
*      PRINT *,'NBELEM=',nbelem
*
*       remplissage du segment lctc
*
      SEGINI LCTC
      DO 600 I=1,NBELEM
c       l'element est il actif
        I1 = NUM(1,I)
*        print *,'noeud lx ',i1
        FLAG1 = .FALSE.
        DO 400 J=1,NPLX
          IF (IPLX(J) .EQ. I1 ) FLAG1 = .TRUE.
 400    CONTINUE
c
        IF  (FLAG1) THEN
*
*      PRINT *,'element actif'
*
c      l'element est actif on cree un mctc elementaire de trois points
          NNO1 = 2
          NNO2 = 1
          SEGINI MCTC
          IM2 = MCTC
          IPOT1(1) = NUM(2,I)
          IPOT1(2) = NUM(3,I)
          IPOT2(1) = NUM(4,I)
c
         DO 500 J=1,I-1
c          on test  si le mctc a un point commun avec
c          ceux deja mis
             IM1 = IMCTC(J,1)
             IF ( IMCTC(J,2) .NE. 0) THEN
*             points communs ?
               CALL IMPOS5(IM1,IM2,IRET)
               IF (IRET .NE. 0) THEN
*                  assemblage des deux mctc
c                  im2 est remplace par le mctc resulatant de
c                  l'assemblage
                   CALL IMPOS6(IM1,IM2,IRET)
c                  invalidation du mctc im1
                   IMCTC(J,2)=0
               ENDIF
             ENDIF
 500     CONTINUE
         IMCTC(I,1)=IM2
         IMCTC(I,2)=1
c
        ENDIF
 600   CONTINUE
       SEGDES MELEME
c
c   creation du maillage correspondant formé de seg2
c
c
        NBELEM = 0
        DO 700 I=1,NB
           IF (IMCTC(I,2) .EQ. 1) THEN
                MCTC = IMCTC(I,1)
                NBELEM = NBELEM + IPOT1(/1) + IPOT2(/1)
           ENDIF
 700    CONTINUE
        NBREF = 0
        NBNN = 2
        NBSOUS = 0
        SEGINI MELEME
        MAIL1 = MELEME
        ITYPEL = 2
c
        INDI1 = 0
        DO 1000 I=1,NB
           MCTC = IMCTC(I,1)
           IF (IMCTC(I,2) .EQ. 1) THEN
c          ligne inferieure
              DO 800 J = 1,(IPOT1(/1)-1)
                INDI1 = INDI1 + 1
                NUM(1,INDI1)=IPOT1(J+1)
                NUM(2,INDI1)=IPOT1(J)
 800          CONTINUE
c          premiere interconnection
              INDI1 = INDI1 + 1
              NNN = IPOT1(/1)
              NUM(1,INDI1 )=IPOT2(1)
              NUM(2,INDI1 )=IPOT1(NNN)
 
c          ligne superieure
              DO 900 J = 1,(IPOT2(/1)-1)
                INDI1 = INDI1 + 1
                NUM(1,INDI1)=IPOT2(J+1)
                NUM(2,INDI1)=IPOT2(J)
 900          CONTINUE
c          deuxieme interconnection
              INDI1 = INDI1 + 1
              NNN = IPOT2(/1)
              NUM(1,INDI1)=IPOT1(1)
              NUM(2,INDI1)=IPOT2(NNN)
           ENDIF
           SEGSUP MCTC
 1000   CONTINUE
c       desactivation des meleme
        SEGSUP LCTC,MPLX
        MELEME = MAIL1
        SEGDES MELEME
        CALL ECROBJ('MAILLAGE',MELEME)
        RETURN
        END