C LIAPOR SOURCE CB215821 26/08/24 21:17:08 12622 C C FABRIQUE LES ELEMENTS LIAISON POUR LES ELEMENTS JOINT POREUX (BALD). C CES ELEMENTS JOINTS SONT COMPOSES PAR TROIS SURFACES: LES SURFACES TOP C ET BOT SONT MAILLEES AVEC DES ELEMENTS QUA8 (TRI6), LA SURFACE AU C MILIEU AVEC DES QUA4 (TRI3). L'ELEMENT LIAISON CREE A 20 (15) NOEUDS. C SUBROUTINE LIAPOR(IPT1,IPT2,IPT3,MELEME,PREC) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (a-h,o-z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCREEL -INC SMELEME -INC SMCOORD SEGMENT MTRAV REAL*8 TA(NBELEM) INTEGER NP1(NBELE1),NP2(NBELE1) ENDSEGMENT C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME DIMENSION ITEST(0:15) IDIMP1 = IDIM+1 SEGACT MCOORD PREC3=3.*PREC TMAX=-XGRAND TMIN= XGRAND NB1=IPT1.NUM(/2) NB2=IPT2.NUM(/2) NB3=IPT3.NUM(/2) NBMAX=MIN(NB1,NB2,NB3) NBNN=IPT1.NUM(/1) NBNM=IPT3.NUM(/1) IF ((NBNN.NE.IPT2.NUM(/1)).OR.(NBNN.EQ.NBNM).OR. . (NBSOM(IPT1.ITYPEL).NE.NBSOM(IPT3.ITYPEL))) THEN CALL ERREUR(16) RETURN ENDIF DO 40 I=0,(NBCOUL-1) ITEST(I)=0 40 CONTINUE DO 41 I=1,NB1 ITEST(IPT1.ICOLOR(I))=1 41 CONTINUE DO 42 I=1,NB2 ITEST(IPT2.ICOLOR(I))=1 42 CONTINUE DO 43 I=1,NB3 ITEST(IPT3.ICOLOR(I))=1 43 CONTINUE ICHCOL=-1 DO 44 I=0,(NBCOUL-1) IF (ITEST(I).EQ.1) THEN IF (ICHCOL.EQ.-1) THEN ICHCOL=I ELSE ICHCOL=ITABM(ICHCOL,I) ENDIF ENDIF 44 CONTINUE NBELEM=NB2 NBELE1=NBELEM+1 SEGINI,MTRAV DO 11 I=1,NB2 Z=0. DO 12 J=1,NBNN IREF=IPT2.NUM(J,I)*IDIMP1-IDIM Z=Z+XCOOR(IREF)+XCOOR(IREF+1) IF (IDIM.NE.2) Z=Z+XCOOR(IREF+2) 12 CONTINUE Z=Z/NBNN TA(I)=Z IF(Z.GT.TMAX) TMAX=Z IF(Z.LT.TMIN) TMIN=Z 11 CONTINUE C C CLASSEMENT APPROXIMATIF PAR ' DISTANCE ' C IF ((TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6 TMAX=TMAX+1. TMIN=TMIN-1. 6 CONTINUE TDEC=(TMAX-TMIN)/NBELEM*1.0001 N = PREC/TDEC + 1. C* Boucle 3 redondante avec SEGINI,MTRAV C* DO 3 I=1,NBELE1 C* 3 NP1(I)=0 DO 4 I=1,NBELEM IPLA=(TA(I)-TMIN)/TDEC+1. NP1(IPLA)=NP1(IPLA)+1 4 CONTINUE DO 400 I=2,NBELE1 NP1(I)=NP1(I-1)+NP1(I) 400 CONTINUE DO 5 I=1,NBELEM IPLA=(TA(I)-TMIN)/TDEC+1. IPLB=NP1(IPLA) NP1(IPLA)=NP1(IPLA)-1 NP2(IPLB)=I 5 CONTINUE C C DANS NP1 ADDRESSE DU DEBUT DE ZONE C DANS NP2 NUMERO DES ELEMENTS EN NUMEROTATION LOCALE C DANS TA DISTANCE DES ELEMENTS C C IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES. NBREF=0 NBSOUS=0 NBNNOR=NBNN NBNN=2*NBNN+NBNM NBELEM=NB1+NB2 SEGINI MELEME IPT4=MELEME NBELEM=NB2 NUMELG=0 C C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT C COQUE C DO 20 I=1,NB1 ZAA=0. DO 21 J=1,NBNNOR IREF=IPT1.NUM(J,I)*IDIMP1-IDIM ZAA=ZAA+XCOOR(IREF)+XCOOR(IREF+1) IF (IDIM.NE.2) ZAA=ZAA+XCOOR(IREF+2) 21 CONTINUE ZAA=ZAA/NBNNOR IZO=(ZAA-TMIN)/TDEC+1. IZO1=IZO-N IZO2=IZO+N IF(IZO1.LT.1) IZO1=1 IF(IZO2.GT.NBELEM) IZO2=NBELEM IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20 DO 28 IZO=IZO1,IZO2 IDEP=NP1(IZO)+1 IFIN=NP1(IZO+1) IF(IFIN.LT.IDEP) GO TO 28 DO 23 JFA=IDEP,IFIN IB=NP2(JFA) IF(ABS(TA(IB)-ZAA).GT.PREC3) GO TO 23 IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM DO 24 IK=1,NBNNOR IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24 IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24 IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) # GOTO 24 ISTA=IK GO TO 26 24 CONTINUE GO TO 23 26 CONTINUE ISENS=1 ISTA1=ISTA+1 ISTAA=ISTA IF (ISTA1.GT.NBNNOR) ISTA1=1 IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM Z=XCOOR(IREFA)-XCOOR(IREFB) IF(ABS(Z).GT.PREC) ISENS=-1 Z=XCOOR(IREFA+1)-XCOOR(IREFB+1) IF(ABS(Z).GT.PREC) ISENS=-1 IF (IDIM.NE.2) THEN Z=XCOOR(IREFA+2)-XCOOR(IREFB+2) IF (ABS(Z).GT.PREC) ISENS=-1 ENDIF DO 30 IJ=2,NBNNOR IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM ISTAA=ISTAA+ISENS IF (ISTAA.EQ.0) ISTAA=NBNNOR IF (ISTAA.GT.NBNNOR) ISTAA=1 IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM DO 32 KLP=1,IDIM Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1) IF(ABS(Z).GT.PREC) GO TO 23 32 CONTINUE 30 CONTINUE C IZC=(ZAA-TMIN)/TDEC+1. DO 33 IC=1,NB3 Z=0. DO 31 J=1,NBNM IREF=IPT3.NUM(J,IC)*IDIMP1-IDIM Z=Z+XCOOR(IREF)+XCOOR(IREF+1) IF (IDIM.NE.2) Z=Z+XCOOR(IREF+2) 31 CONTINUE Z=Z/NBNM IF(ABS(ZAA-Z).GT.PREC3) GO TO 33 C ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM DO 34 IK=1,NBNM IREFB=IPT3.NUM(IK,IC)*IDIMP1-IDIM IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 34 IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 34 IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) # GOTO 34 ISTC=IK GO TO 36 34 CONTINUE GO TO 33 36 CONTINUE ISENT=1 ISTC1=ISTC+1 ISTCC=ISTC IF (ISTC1.GT.NBNM) ISTC1=1 IREFA=IPT1.NUM(3,I)*IDIMP1-IDIM IREFB=IPT3.NUM(ISTC1,IC)*IDIMP1-IDIM Z=XCOOR(IREFA)-XCOOR(IREFB) IF(ABS(Z).GT.PREC) ISENT=-1 Z=XCOOR(IREFA+1)-XCOOR(IREFB+1) IF(ABS(Z).GT.PREC) ISENT=-1 IF (IDIM.NE.2) THEN Z=XCOOR(IREFA+2)-XCOOR(IREFB+2) IF (ABS(Z).GT.PREC) ISENT=-1 ENDIF DO 50 IJ=3,NBNNOR,2 IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM ISTCC=ISTCC+ISENT IF (ISTCC.EQ.0) ISTCC=NBNM IF (ISTCC.GT.NBNM) ISTCC=1 IREFB=IPT3.NUM(ISTCC,IC)*IDIMP1-IDIM DO 52 KLP=1,IDIM Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1) IF(ABS(Z).GT.PREC) GO TO 33 52 CONTINUE 50 CONTINUE C CREATION D'UN ELEM RACCORD NUMELG=NUMELG+1 IF (NUMELG.GT.NBMAX) THEN CALL ERREUR(31) GOTO 101 ENDIF IM=0 DO 27 IK=1,NBNNOR IP1=IPT1.NUM(IK,I) IP2=IPT2.NUM(ISTA,IB) NUM(IK,NUMELG)=IP1 NUM(NBNNOR+IK,NUMELG)=IP2 ISTA=ISTA+ISENS IF (ISTA.EQ.0) ISTA=NBNNOR IF (ISTA.GT.NBNNOR) ISTA=1 IF (IK.EQ.IBSOM(NSPOS(IPT1.ITYPEL)+IM)) THEN IM=IM+1 IP3=IPT3.NUM(ISTC,IC) NUM(2*NBNNOR+IM,NUMELG)=IP3 ISTC=ISTC+ISENT IF (ISTC.EQ.0) ISTC=NBNM IF (ISTC.GT.NBNM) ISTC=1 IF ((IP1.NE.IP2).AND.(IP1.NE.IP3).AND.(IP2.NE.IP3)) GO TO 27 INTERR(1)=NUMELG CALL ERREUR(101) ENDIF IF (IP1.NE.IP2) GO TO 27 INTERR(1)=NUMELG CALL ERREUR(101) 27 CONTINUE 33 CONTINUE C 23 CONTINUE 28 CONTINUE 20 CONTINUE C WRITE(IOIMP,29) NUMELG C 29 FORMAT(//,' NOMBRE D''ELEMENTS DE LIAISON CREES : ',I5) NBELEM=NUMELG MELEME=0 IF (NBELEM.EQ.0) GOTO 101 SEGINI MELEME IF (NBNN.EQ.15) ITYPEL=30 IF (NBNN.EQ.20) ITYPEL=31 DO 401 J=1,NBELEM ICOLOR(J)=ICHCOL DO 100 I=1,NBNN NUM(I,J)=IPT4.NUM(I,J) 100 CONTINUE 401 CONTINUE 101 SEGSUP IPT4 SEGSUP MTRAV RETURN END