1 : C PRCOAP SOURCE CHAT 07/10/29 21:25:43 5940 2 : C CE SOUS PROGRAMME RETROUVE LE CONTOUR APPARENT (??) D'UN OBJET 3 : C IL EST DERIVE DE PRCONT 4 : C 5 : SUBROUTINE PRCOAP(IPT9,IPT2,ICPR,IVU,IRETNE) 6 : C 7 : IMPLICIT INTEGER(I-N) 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC SMELEME 11 : -INC SMCOORD 12 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 13 : SEGMENT IDCP(ITE) 14 : SEGMENT NTSEG(0) 15 : SEGMENT IVU(0) 16 : SEGMENT KON(NBCON,NMAX) 17 : C 18 : MELEME=IPT9 19 : IPT8=MELEME 20 : SEGACT MELEME 21 : ITE=IVU(/1) 22 : C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU 23 : C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS 24 : NBCON=7 25 : NBCONR=NBCON-1 26 : NMAX=(10*ITE)/NBCON 27 : SEGINI KON 28 : C MISE A ZERO DU TABLEAU KON 29 : DO 10 I=1,NMAX 30 : DO 10 J=1,NBCON 31 : KON(J,I)=0 32 : 10 CONTINUE 33 : C FABRICATION DU TABLEAU DES CONNECTIONS 34 : C POINT FINAL 35 : ICHAIN=ITE 36 : SEGACT MELEME 37 : IPT1=MELEME 38 : DO 100 IOB=1,MAX(1,LISOUS(/1)) 39 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB) 40 : SEGACT IPT1 41 : IF (KSURF(IPT1.ITYPEL).NE.0) THEN 42 : NBELEM=IPT1.NUM(/2) 43 : NBFAC=LTEL(1,IPT1.ITYPEL) 44 : IAD=LTEL(2,IPT1.ITYPEL)-1 45 : IF (NBFAC.NE.0) THEN 46 : DO 101 IFAC=1,NBFAC 47 : ITYP=LDEL(1,IAD+IFAC) 48 : NPFAC=KDFAC(1,ITYP) 49 : JAD=LDEL(2,IAD+IFAC)-1 50 : IDEP=KDFAC(2,ITYP) 51 : IFEP=IDEP+3*(KDFAC(3,ITYP)-1) 52 : * TRIANGLE ELEMENTAIRE 53 : * ON NE GARDE QUE CEUX QUI ONT LEURS TROIS NOEUDS VUS 54 : DO 101 ITRIAN=IDEP,IFEP,3 55 : IAFA=LFAC(JAD+KFAC(ITRIAN)) 56 : IBFA=LFAC(JAD+KFAC(ITRIAN+1)) 57 : ICFA=LFAC(JAD+KFAC(ITRIAN+2)) 58 : DO 102 IEL=1,NBELEM 59 : IA=ICPR(IPT1.NUM(IAFA,IEL)) 60 : IB=ICPR(IPT1.NUM(IBFA,IEL)) 61 : IC=ICPR(IPT1.NUM(ICFA,IEL)) 62 : IF (IVU(IA).GE.1.AND.IVU(IB).GE.1.AND.IVU(IC).GE.1) 63 : * THEN 64 : DO 103 ICOT=1,3 65 : IF (ICOT.EQ.1) THEN 66 : N1=IA 67 : N2=IB 68 : ELSEIF (ICOT.EQ.2) THEN 69 : N1=IB 70 : N2=IC 71 : ELSEIF (ICOT.EQ.3) THEN 72 : N1=IC 73 : N2=IA 74 : ENDIF 75 : NI=N1 76 : NJ=N2 77 : IF (N1*N2.EQ.0) THEN 77 : CALL ERREUR(26) 78 : SEGSUP KON 79 : SEGDES MELEME 80 : RETURN 81 : ENDIF 82 : IPO=0 83 : 23 CONTINUE 84 : 24 CONTINUE 85 : DO 25 K=1,NBCONR 86 : IF (KON(K,NI).EQ.0) GOTO 26 87 : IF (KON(K,NI).EQ.NJ) GOTO 27 88 : 25 CONTINUE 89 : IF (KON(NBCON,NI).EQ.0) GOTO 28 90 : NI=KON(NBCON,NI) 91 : GOTO 24 92 : 27 CONTINUE 93 : KON(K,NI)=-1 94 : GOTO 29 95 : 26 CONTINUE 96 : KON(K,NI)=NJ 97 : GOTO 29 98 : 28 CONTINUE 99 : ICHAIN=ICHAIN+1 100 : IF (ICHAIN.GE.NMAX) THEN 101 : C ON FAIT UN SEGADJ SUR LE TABLEAU DE CONNECTIONS 102 : NMAX=NMAX+1 103 : SEGADJ KON 104 : DO 70 J=1,NBCON 105 : KON(J,NMAX)=0 106 : 70 CONTINUE 107 : ENDIF 108 : KON(NBCON,NI)=ICHAIN 109 : K=1 110 : NI=ICHAIN 111 : GOTO 26 112 : 29 CONTINUE 113 : IF (IPO.NE.1) THEN 114 : NI=N2 115 : NJ=N1 116 : IPO=1 117 : GOTO 23 118 : ENDIF 119 : 103 CONTINUE 120 : ENDIF 121 : 102 CONTINUE 122 : 101 CONTINUE 123 : ENDIF 124 : ENDIF 125 : IF (LISOUS(/1).NE.0) SEGDES IPT1 126 : 100 CONTINUE 127 : SEGDES MELEME 128 : IF (IIMPI.EQ.2)WRITE (IOIMP,1122)((KON(I,J),I=1,NBCON),J=1,NMAX) 129 : 1122 FORMAT(1X,14I5) 130 : SEGDES MELEME 131 : SEGINI IDCP 132 : DO 40 I=1,ICPR(/1) 133 : IF (ICPR(I).EQ.0) GOTO 40 134 : IDCP(ICPR(I))=I 135 : 40 CONTINUE 136 : C CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME 137 : NBSOUS=0 138 : NBREF=0 139 : NBELEM=0 140 : DO 41 J=1,ITE 141 : JJ=J 142 : 43 DO 42 I=1,NBCONR 143 : IF (KON(I,JJ).LT.J) GOTO 42 144 : NBELEM=NBELEM+1 145 : 42 CONTINUE 146 : IF (KON(NBCON,JJ).EQ.0) GOTO 41 147 : JJ=KON(NBCON,JJ) 148 : GOTO 43 149 : 41 CONTINUE 150 : IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM 151 : 1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6) 152 : IRETNE=NBELEM 153 : NBNN=2 154 : SEGINI MELEME 155 : ITYPEL=2 156 : IEL=0 157 : KAUX=1 158 : 50 CONTINUE 159 : K=KAUX 160 : KAUXR=KAUX 161 : 51 DO 52 KL=1,NBCONR 162 : ITRA=KON(KL,K) 163 : IF (ITRA.EQ.-1) GOTO 52 164 : IF (ITRA.EQ.0) GOTO 53 165 : GOTO 54 166 : 52 CONTINUE 167 : K=KON(NBCON,K) 168 : IF (K.NE.0) GOTO 51 169 : 53 CONTINUE 170 : KAUX=KAUX+1 171 : IF (KAUX.EQ.ITE+1) GOTO 63 172 : GOTO 50 173 : 54 CONTINUE 174 : KPRESS=KAUXR 175 : GOTO 55 176 : 57 CONTINUE 177 : KL=1 178 : 55 DO 56 L=KL,NBCONR 179 : M=KON(L,K) 180 : IF (M.EQ.0) GOTO 53 181 : IF (M.EQ.-1) GOTO 56 182 : GOTO 58 183 : 56 CONTINUE 184 : K=KON(NBCON,K) 185 : IF (K.EQ.0) GOTO 53 186 : GOTO 57 187 : 58 CONTINUE 188 : IEL=IEL+1 189 : NUM(1,IEL)=IDCP(KPRESS) 190 : NUM(2,IEL)=IDCP(M) 191 : ICOLOR(IEL)=1 192 : KON(L,K)=-1 193 : M1=M 194 : 59 DO 60 L=1,NBCONR 195 : IF (KON(L,M1).EQ.0) GOTO 62 196 : IF (KON(L,M1).EQ.KPRESS) GOTO 61 197 : 60 CONTINUE 198 : M1=KON(NBCON,M1) 199 : IF (M1.EQ.0) GOTO 62 200 : GOTO 59 201 : 61 CONTINUE 202 : KON(L,M1)=-1 203 : 62 CONTINUE 204 : KPRESS=M 205 : K=KPRESS 206 : GOTO 57 207 : 63 CONTINUE 208 : * LE RESULTAT 209 : IPT2=MELEME 210 : IF (IIMPI.NE.0) THEN 211 : WRITE (IOIMP,*) ' CONTOUR APPARENT DANS PRCOAP ' 211 : CALL ECROBJ('MAILLAGE',IPT2) 211 : CALL PRLIST 211 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 212 : ENDIF 213 : SEGSUP KON,IDCP 214 : C 215 : RETURN 216 : END 217 : 218 : 219 : 220 : 221 : 222 : 223 :
© Cast3M 2003 - All rights reserved.
Disclaimer