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