C PRCOAP SOURCE CHAT 07/10/29 21:25:43 5940 C CE SOUS PROGRAMME RETROUVE LE CONTOUR APPARENT (??) D'UN OBJET C IL EST DERIVE DE PRCONT C SUBROUTINE PRCOAP(IPT9,IPT2,ICPR,IVU,IRETNE) C IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC SMCOORD SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) SEGMENT IDCP(ITE) SEGMENT NTSEG(0) SEGMENT IVU(0) SEGMENT KON(NBCON,NMAX) C MELEME=IPT9 IPT8=MELEME SEGACT MELEME ITE=IVU(/1) C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS NBCON=7 NBCONR=NBCON-1 NMAX=(10*ITE)/NBCON SEGINI KON C MISE A ZERO DU TABLEAU KON DO 10 I=1,NMAX DO 10 J=1,NBCON KON(J,I)=0 10 CONTINUE C FABRICATION DU TABLEAU DES CONNECTIONS C POINT FINAL ICHAIN=ITE SEGACT MELEME IPT1=MELEME DO 100 IOB=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB) SEGACT IPT1 IF (KSURF(IPT1.ITYPEL).NE.0) THEN NBELEM=IPT1.NUM(/2) NBFAC=LTEL(1,IPT1.ITYPEL) IAD=LTEL(2,IPT1.ITYPEL)-1 IF (NBFAC.NE.0) THEN DO 101 IFAC=1,NBFAC ITYP=LDEL(1,IAD+IFAC) NPFAC=KDFAC(1,ITYP) JAD=LDEL(2,IAD+IFAC)-1 IDEP=KDFAC(2,ITYP) IFEP=IDEP+3*(KDFAC(3,ITYP)-1) * TRIANGLE ELEMENTAIRE * ON NE GARDE QUE CEUX QUI ONT LEURS TROIS NOEUDS VUS DO 101 ITRIAN=IDEP,IFEP,3 IAFA=LFAC(JAD+KFAC(ITRIAN)) IBFA=LFAC(JAD+KFAC(ITRIAN+1)) ICFA=LFAC(JAD+KFAC(ITRIAN+2)) DO 102 IEL=1,NBELEM IA=ICPR(IPT1.NUM(IAFA,IEL)) IB=ICPR(IPT1.NUM(IBFA,IEL)) IC=ICPR(IPT1.NUM(ICFA,IEL)) IF (IVU(IA).GE.1.AND.IVU(IB).GE.1.AND.IVU(IC).GE.1) * THEN DO 103 ICOT=1,3 IF (ICOT.EQ.1) THEN N1=IA N2=IB ELSEIF (ICOT.EQ.2) THEN N1=IB N2=IC ELSEIF (ICOT.EQ.3) THEN N1=IC N2=IA ENDIF NI=N1 NJ=N2 IF (N1*N2.EQ.0) THEN CALL ERREUR(26) SEGSUP KON SEGDES MELEME RETURN ENDIF IPO=0 23 CONTINUE 24 CONTINUE DO 25 K=1,NBCONR IF (KON(K,NI).EQ.0) GOTO 26 IF (KON(K,NI).EQ.NJ) GOTO 27 25 CONTINUE IF (KON(NBCON,NI).EQ.0) GOTO 28 NI=KON(NBCON,NI) GOTO 24 27 CONTINUE KON(K,NI)=-1 GOTO 29 26 CONTINUE KON(K,NI)=NJ GOTO 29 28 CONTINUE ICHAIN=ICHAIN+1 IF (ICHAIN.GE.NMAX) THEN C ON FAIT UN SEGADJ SUR LE TABLEAU DE CONNECTIONS NMAX=NMAX+1 SEGADJ KON DO 70 J=1,NBCON KON(J,NMAX)=0 70 CONTINUE ENDIF KON(NBCON,NI)=ICHAIN K=1 NI=ICHAIN GOTO 26 29 CONTINUE IF (IPO.NE.1) THEN NI=N2 NJ=N1 IPO=1 GOTO 23 ENDIF 103 CONTINUE ENDIF 102 CONTINUE 101 CONTINUE ENDIF ENDIF IF (LISOUS(/1).NE.0) SEGDES IPT1 100 CONTINUE SEGDES MELEME IF (IIMPI.EQ.2)WRITE (IOIMP,1122)((KON(I,J),I=1,NBCON),J=1,NMAX) 1122 FORMAT(1X,14I5) SEGDES MELEME SEGINI IDCP DO 40 I=1,ICPR(/1) IF (ICPR(I).EQ.0) GOTO 40 IDCP(ICPR(I))=I 40 CONTINUE C CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME NBSOUS=0 NBREF=0 NBELEM=0 DO 41 J=1,ITE JJ=J 43 DO 42 I=1,NBCONR IF (KON(I,JJ).LT.J) GOTO 42 NBELEM=NBELEM+1 42 CONTINUE IF (KON(NBCON,JJ).EQ.0) GOTO 41 JJ=KON(NBCON,JJ) GOTO 43 41 CONTINUE IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM 1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6) IRETNE=NBELEM NBNN=2 SEGINI MELEME ITYPEL=2 IEL=0 KAUX=1 50 CONTINUE K=KAUX KAUXR=KAUX 51 DO 52 KL=1,NBCONR ITRA=KON(KL,K) IF (ITRA.EQ.-1) GOTO 52 IF (ITRA.EQ.0) GOTO 53 GOTO 54 52 CONTINUE K=KON(NBCON,K) IF (K.NE.0) GOTO 51 53 CONTINUE KAUX=KAUX+1 IF (KAUX.EQ.ITE+1) GOTO 63 GOTO 50 54 CONTINUE KPRESS=KAUXR GOTO 55 57 CONTINUE KL=1 55 DO 56 L=KL,NBCONR M=KON(L,K) IF (M.EQ.0) GOTO 53 IF (M.EQ.-1) GOTO 56 GOTO 58 56 CONTINUE K=KON(NBCON,K) IF (K.EQ.0) GOTO 53 GOTO 57 58 CONTINUE IEL=IEL+1 NUM(1,IEL)=IDCP(KPRESS) NUM(2,IEL)=IDCP(M) ICOLOR(IEL)=1 KON(L,K)=-1 M1=M 59 DO 60 L=1,NBCONR IF (KON(L,M1).EQ.0) GOTO 62 IF (KON(L,M1).EQ.KPRESS) GOTO 61 60 CONTINUE M1=KON(NBCON,M1) IF (M1.EQ.0) GOTO 62 GOTO 59 61 CONTINUE KON(L,M1)=-1 62 CONTINUE KPRESS=M K=KPRESS GOTO 57 63 CONTINUE * LE RESULTAT IPT2=MELEME IF (IIMPI.NE.0) THEN WRITE (IOIMP,*) ' CONTOUR APPARENT DANS PRCOAP ' CALL ECROBJ('MAILLAGE',IPT2) CALL PRLIST CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) ENDIF SEGSUP KON,IDCP C RETURN END