1 : C J3COUP SOURCE CHAT 05/01/13 00:46:14 5004 2 : SUBROUTINE J3COUP(WWORK1,WORK2,VWORK1,VWORK2,IRED,TOL,IRET) 3 : C---------------------------------------------------- 4 : C COUPURE DES FACES A ET B 5 : C 6 : C CODE IST(1,I): 0 point non traite 7 : C 1 est sur le segment IST(2,I) 8 : C 2 est sur les segments IST(2,I) et IST(3,I) 9 : C -1 est a l'interieur 10 : C -2 est a l'exterieur 11 : C 12 : C CODE CRO(J,I): 1 cote sur le segment 13 : C -1 cote interieur 14 : C -2 cote exterieur 15 : C 16 : C IRED=0 EMPECHE LA REDISTRIBUTION DES TROUS 17 : C 18 : C PP 6/97,11/98 19 : C Pierre Pegon/JRC Ispra 20 : C---------------------------------------------------- 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8(A-H,O-Z) 23 : -INC CCOPTIO 24 : C 25 : SEGMENT WORK 26 : REAL*8 XYC(2,NPTO) 27 : INTEGER IST(3,NPTO) 28 : REAL*8 DENS(NPTO) 29 : INTEGER JUN 30 : ENDSEGMENT 31 : POINTEUR WORK1.WORK,WORK2.WORK 32 : C 33 : SEGMENT WWORK 34 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 35 : INTEGER FWORK 36 : INTEGER TWORK(NTROU) 37 : ENDSEGMENT 38 : SEGMENT WWORK1.WWORK 39 : C 40 : SEGMENT VWORK 41 : INTEGER FWWORK(NFACE) 42 : ENDSEGMENT 43 : SEGMENT VWORK1.VWORK,VWORK2.VWORK 44 : C 45 : SEGMENT JUNC 46 : INTEGER CRO(2,NPTO) 47 : ENDSEGMENT 48 : SEGMENT JUNC1.JUNC,JUNC2.JUNC 49 : C 50 : LOGICAL LAINB,LAOUB,LAONB 51 : C 52 : IF (IIMPI.EQ.1789)THEN 53 : WRITE(IOIMP,*)'>>> On entre dans j3coup <<<' 54 : ENDIF 55 : C 56 : WORK1=WWORK1.FWORK 57 : C 58 : C ON CHERCHE LE NB D'INTERSECTION AVEC B 59 : C 60 : NPTO1=WORK1.XYC(/2) 61 : JUNC1=WORK1.JUN 62 : NPTO2=WORK2.XYC(/2) 63 : JUNC2=WORK2.JUN 64 : C 65 : NINTER=0 66 : DO IE1=1,NPTO1 67 : ISU=WORK1.IST(1,IE1) 68 : IF(ISU.GT.0)THEN 68 : CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2) 69 : ICRO2=JUNC2.CRO(1,I2) 70 : ICRP2=JUNC2.CRO(2,I2) 71 : IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN 72 : NINTER=NINTER+1 73 : IF(ICRO2+ICRP2.EQ.-2)THEN 74 : NINTER=NINTER+1 75 : ENDIF 76 : ENDIF 77 : ENDIF 78 : ENDDO 79 : C 80 : C NINTER DOIT ETRE UN MULTIPLE DE 2 81 : C 82 : NFAC1=NINTER/2 83 : IF(NINTER-2*NFAC1.NE.0)THEN 84 : IRET=IRET+1 85 : WRITE(IOIMP,*)'J3COUP: LE NOMBRE D"INTERSECTIONS DOIT ETRE PAIR' 86 : RETURN 87 : ENDIF 88 : NFAC1=NFAC1+1 89 : C 90 : C ON PREPARE QUI VA RECEVOIR LES FACES 91 : C 92 : NFACE=NFAC1 93 : SEGINI,VWORK1,VWORK2 94 : IFAC1=0 95 : IFAC2=0 96 : C 97 : C ON LOOP SUR LES FACES 98 : C 99 : IPLA1=1 100 : DO IE0=1,NFAC1 101 : C 102 : C ON CHERCHE LE DEBUT D'UNE INTERSECTION AVEC B 103 : C 104 : DO IE1=IPLA1,NPTO1 105 : ISU=WORK1.IST(1,IE1) 106 : IF(ISU.GT.0)THEN 106 : CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2) 107 : ICRO2=JUNC2.CRO(1,I2) 108 : ICRP2=JUNC2.CRO(2,I2) 109 : IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN 110 : GOTO 1 111 : ENDIF 112 : ENDIF 113 : ENDDO 114 : C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B! 115 : IF(IE0.EQ.NFAC1)GOTO 5 116 : IRET=IRET+1 117 : WRITE(IOIMP,*)'J3COUP: LE NOMBRE DE BLOCKS N"EST PAS ATTEINT' 118 : RETURN 119 : C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B! 120 : C 121 : C ON FORME UN NOUVEAU BLOCK EN CIRCULANT SUR B ET A TJS VERS 122 : C L'INTERIEUR, EN INVALIDANT LES INTERSECTION DE A AU FUR ET A 123 : C MESURE QUE ON LES RENCONTRE, ET JUSQU'A FERMETURE 124 : C 125 : C A) ON STOCKE LE PREMIER POINT DE LA NOUVELLE FACE ... 126 : C 127 : 1 CONTINUE 128 : IPLA1=IE1 129 : I1=IPLA1 130 : C 131 : NPTO=NPTO1+NPTO2 132 : SEGINI,WORK 133 : JUN=0 134 : IPTO=1 135 : DO IE2=1,2 136 : XYC(IE2,IPTO)=WORK1.XYC(IE2,IPLA1) 137 : ENDDO 138 : DENS(IPTO)=WORK1.DENS(IPLA1) 139 : C 140 : C B) ... PUIS ON L'INVALIDE 141 : C (PT DE BRANCHEMENT EN CAS DE PARCOURS MULTIPLE) 142 : C 143 : 2 CONTINUE 144 : WORK1.IST(1,I1)=0 145 : C 146 : C C) ON INITIALISE ENSUITE LE PARCOURS SUR B 147 : C "SENS DE LA NUMEROTATION" +1 ou -1 ? 148 : C FACILE SAUF EN CAS D'INTER MULTIPLE 149 : C 150 : IF(ICRO2+ICRP2.EQ.-2)THEN 150 : CALL J3ANG1(WORK1.XYC,NPTO1,I1,WORK2.XYC,NPTO2,I2,TOL,AG1,AG2) 151 : IF(ABS(AG1).LT.ABS(AG2))THEN 152 : ISEN2=-1 153 : ELSE 154 : ISEN2=+1 155 : ENDIF 156 : ELSE 157 : IF(ICRO2.EQ.-1)THEN 158 : ISEN2=-1 159 : ELSE 160 : ISEN2=+1 161 : ENDIF 162 : ENDIF 163 : C 164 : C D) ON RESTE SUR B JUSQU'AU CONTACT AVEC A 165 : C ON REVIENT ALORS SUR A SAUF SI IL Y A 2 COTE INTERIEUR ET QUE 166 : C ON LE PARCOURT DANS LE SENS + (DEDANS!) 167 : C 168 : DO IE2=1,NPTO2 169 : I2=I2+ISEN2 170 : IF((I2.LT.1).OR.(I2.GT.NPTO2))I2=I2-ISEN2*NPTO2 171 : C 172 : IPTO=IPTO+1 173 : DO IE3=1,2 174 : XYC(IE3,IPTO)=WORK2.XYC(IE3,I2) 175 : ENDDO 176 : DENS(IPTO)=WORK2.DENS(I2) 177 : C 178 : ISU=WORK2.IST(1,I2) 179 : IF(ISU.GT.0)THEN 180 : ICRO2=JUNC2.CRO(1,I2) 181 : ICRP2=JUNC2.CRO(2,I2) 182 : IF((ISEN2.EQ.-1).OR.(ICRO2.NE.-1).OR.(ICRP2.NE.-1))GOTO 3 183 : ENDIF 184 : C 185 : ENDDO 186 : C 187 : IRET=IRET+1 188 : WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR B!' 189 : RETURN 190 : C 191 : 3 CONTINUE 192 : C 193 : C E) ON INITIALISE LE PARCOURS SUR A (LE SENS DE PARCOURS EST TJ +1!) 194 : C 194 : CALL J3NUMP(WORK2.IST(1,I2),NPTO1,I1) 195 : DO IE2=1,NPTO1 196 : C 197 : I1=I1+1 198 : IF(I1.GT.NPTO1)I1=I1-NPTO1 199 : IF(I1.EQ.IPLA1)GOTO 4 200 : C 201 : IPTO=IPTO+1 202 : DO IE3=1,2 203 : XYC(IE3,IPTO)=WORK1.XYC(IE3,I1) 204 : ENDDO 205 : DENS(IPTO)=WORK1.DENS(I1) 206 : C 207 : ISU=WORK1.IST(1,I1) 208 : IF(ISU.GT.0)THEN 208 : CALL J3NUMP(WORK1.IST(1,I1),NPTO2,I2) 209 : ICRO2=JUNC2.CRO(1,I2) 210 : ICRP2=JUNC2.CRO(2,I2) 211 : IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN 212 : GOTO 2 213 : ENDIF 214 : ENDIF 215 : C 216 : ENDDO 217 : C 218 : IRET=IRET+1 219 : WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR A!' 220 : RETURN 221 : C 222 : C F) LA FACE WORK EST FINIE, ON LA STOCKE SOIT DANS VWORK1 (FACES 223 : C INTERIEURES A B) SOIT DANS VWORK2 (FACES EXTERIEURES A B) 224 : C WARNING: SI LA FACE INTE A B EST EGALE A B, ON LA 225 : C REND IDENTIQUE A B 226 : C 227 : 4 CONTINUE 228 : C 229 : NPTO=IPTO 230 : SEGADJ,WORK 231 : C 232 : NTROU=0 233 : SEGINI,WWORK 234 : IF (ISEN2.EQ.+1)THEN 235 : IFAC1=IFAC1+1 236 : VWORK1.FWWORK(IFAC1)=WWORK 236 : CALL J3IDEN(WORK,WORK2,TOL) 237 : ELSE 238 : IFAC2=IFAC2+1 239 : VWORK2.FWWORK(IFAC2)=WWORK 240 : ENDIF 241 : FWORK=WORK 242 : IF(IFAC1+IFAC2.EQ.NFAC1)GOTO 6 243 : C 244 : C FIN LOOP SUR LES FACES 245 : C 246 : ENDDO 247 : C 248 : C CAS OU B EST LA DERNIERE FACE (C'EST ALORS L'UNIQUE FACE INTE!) 249 : C 250 : 5 CONTINUE 251 : IF(IFAC1.NE.0)THEN 252 : IRET=IRET+1 253 : WRITE(IOIMP,*)'J3COUP: B NE PEUT ETRE QUE L"UNIQUE FACE INTE' 254 : RETURN 255 : ENDIF 256 : SEGINI,WORK=WORK2 257 : JUN=0 258 : NTROU=0 259 : SEGINI,WWORK 260 : FWORK=WORK 261 : IFAC1=IFAC1+1 262 : VWORK1.FWWORK(IFAC1)=WWORK 263 : C 264 : C ON AJUSTE VWORK1 ET VWORK2 265 : C 266 : 6 CONTINUE 267 : NFACE=IFAC1 268 : SEGADJ,VWORK1 269 : NFACE=IFAC2 270 : SEGADJ,VWORK2 271 : C 272 : C ON VA MAINTENANT DISTRIBUER LES TROU DE A (DANS LES FACES EXTE 273 : C A B (INHIBE SI IRED=0) 274 : C 275 : IF(IRED.EQ.0)RETURN 276 : C 277 : C A) Y-A-T'IL DES TROUS DANS A 278 : C 279 : NTROU1=WWORK1.TWORK(/1) 280 : IF(NTROU1.EQ.0)RETURN 281 : C 282 : C B) ON LOOP SUR LES TROUS DE A QUE L'ON PLACE DANS WORK1 283 : C 284 : DO 11 IE1=1,NTROU1 285 : WORK1=WWORK1.TWORK(IE1) 286 : IF(WORK1.EQ.0)GOTO 11 287 : C 288 : C C) ON LOOP SUR LES FACES DE VWORK2 QUE L'ON PLACE DANS WORK2 289 : C 290 : DO IE2=1,NFACE 291 : WWORK=VWORK2.FWWORK(IE2) 292 : WORK2=FWORK 293 : C 294 : C D) LE TROU WORK1 EST-IL DANS LA FACE WORK2 (TEST MINIMUM)? 295 : C 295 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 296 : IF (IRET.GT.0)THEN 297 : RETURN 298 : ENDIF 299 : NPTO1=WORK1.XYC(/2) 299 : CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) 300 : C 301 : C E) SI OUI, ON LE MET DANS LA FACE ET ON LE RETIRE DE A 302 : C 303 : C>>>>>>>>>>>> .NOT.LAINB EN PLUS ?????? 304 : IF(.NOT.LAOUB)THEN 305 : NTROU=TWORK(/1) 306 : NTROU=NTROU+1 307 : SEGADJ,WWORK 308 : TWORK(NTROU)=WORK1 309 : WWORK1.TWORK(IE1)=0 310 : GOTO 10 311 : C 312 : ENDIF 313 : ENDDO 314 : 10 CONTINUE 315 : 11 CONTINUE 316 : C 317 : C F) ON VERIFIE QUE TOUS LES TROUS DE A ONT ETE DISTRIBUES 318 : C 319 : DO IE1=1,NTROU1 320 : IF(WWORK1.TWORK(IE1).NE.0)THEN 321 : IRET=IRET+1 322 : WRITE(IOIMP,*)'J3COUP: TOUS LES TROUS DE A AURAIENT DUS ETRE' 323 : WRITE(IOIMP,*)' DIDTRIBUES' 324 : RETURN 325 : ENDIF 326 : ENDDO 327 : C 328 : RETURN 329 : END 330 : 331 :
© Cast3M 2003 - All rights reserved.
Disclaimer