1 : C J3SURF SOURCE CHAT 05/01/13 00:47:33 5004 2 : SUBROUTINE J3SURF(VWORK1,TOL) 3 : C---------------------------------------------------- 4 : C ELIMINATION DES CAS TORDUS POUR SURF 5 : C 6 : C PP 9/97 7 : C Pierre Pegon/JRC Ispra 8 : C---------------------------------------------------- 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : DIMENSION XY(2) 12 : C 13 : -INC CCOPTIO 14 : C 15 : SEGMENT VWORK 16 : INTEGER FWWORK(NFACE) 17 : ENDSEGMENT 18 : POINTEUR VWORK1.VWORK 19 : C 20 : SEGMENT WWORK 21 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 22 : INTEGER FWORK 23 : INTEGER TWORK(NTROU) 24 : ENDSEGMENT 25 : C 26 : SEGMENT WORK 27 : REAL*8 XYC(2,NPTO) 28 : INTEGER IST(3,NPTO) 29 : REAL*8 DENS(NPTO) 30 : INTEGER JUN 31 : ENDSEGMENT 32 : POINTEUR WORK1.WORK, WORK2.WORK 33 : C 34 : C ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN 35 : C UN BLOCK COMPOSE DE FACE 36 : C 37 : NBLOCK=VWORK1.FWWORK(/1) 38 : C 39 : C ON BOUCLE SUR CHAQUE BLOCK 40 : C 41 : DO IE1=1,NBLOCK 42 : VWORK=VWORK1.FWWORK(IE1) 43 : NFACE=FWWORK(/1) 44 : C 45 : C ON BOUCLE SUR CHAQUE FACE 46 : C 47 : DO IE2=1,NFACE 48 : WWORK=FWWORK(IE2) 49 : NTROU=TWORK(/1) 50 : C 51 : C S'IL Y A DES TROUS, ON FAIT QUELQUE CHOSE .... 52 : C 53 : IF(NTROU.GT.0)THEN 54 : IF(IIMPI.EQ.1790)THEN 55 : WRITE(IOIMP,*)'J3SURF: FACE A TRAITER' 55 : CALL J3LIWW(WWORK) 56 : ENDIF 57 : C 58 : C S'IL Y A PLUSIEURS TROUS AVEC UN PT COMMUN, ON LES COHALESCE 59 : C 60 : IF(NTROU.GT.1)THEN 61 : C 62 : C A) SIMULATION DE "DO 10 IE3=1,NTROU-1" AVEC NTROU VARIABLE 63 : C 64 : IE3=0 65 : 1 IE3=IE3+1 66 : IF(IE3.GE.NTROU)GOTO 10 67 : WORK1=TWORK(IE3) 68 : NPTO1=WORK1.DENS(/1) 69 : C 70 : C B) BOUCLE SUR LES POINTS DU TROU QUE L'ON CHARGE DANS XY 71 : C 72 : DO IE4=1,NPTO1 73 : IPO1=IE4 74 : XY(1)=WORK1.XYC(1,IE4) 75 : XY(2)=WORK1.XYC(2,IE4) 76 : C 77 : C C) BOUCLE SUR LES TROUS RESTANTS 78 : C 79 : DO IE5=IE3+1,NTROU 80 : IF5=IE5 81 : WORK2=TWORK(IE5) 82 : NPTO2=WORK2.DENS(/1) 82 : CALL J3NOCO(XY,WORK2.XYC,NPTO2,TOL,IPO2) 83 : IF(IPO2.NE.0)GOTO 2 84 : ENDDO 85 : C 86 : ENDDO 87 : C 88 : GOTO 1 89 : C 90 : C D) COHALESCENCE DES TROUS WORK1 ET WORK2 91 : C 92 : 2 NPTO=NPTO1+NPTO2 93 : SEGADJ,WORK1 94 : DO IE4=NPTO,IPO1+NPTO2,-1 95 : WORK1.DENS(IE4)=WORK1.DENS(IE4-NPTO2) 96 : WORK1.XYC(1,IE4)=WORK1.XYC(1,IE4-NPTO2) 97 : WORK1.XYC(2,IE4)=WORK1.XYC(2,IE4-NPTO2) 98 : ENDDO 99 : DO IE4=IPO1,IPO1+NPTO2-1 100 : JE4=IE4-IPO1+IPO2 101 : IF(JE4.GT.NPTO2)JE4=JE4-NPTO2 102 : WORK1.DENS(IE4)=WORK2.DENS(JE4) 103 : WORK1.XYC(1,IE4)=WORK2.XYC(1,JE4) 104 : WORK1.XYC(2,IE4)=WORK2.XYC(2,JE4) 105 : ENDDO 106 : C 107 : C E) SUPPRESSION DE WORK2 108 : C 109 : SEGSUP,WORK2 110 : C 111 : C F) ON REPASSE DANS LA MOULINETTE EN REORGANISANT TWORK 112 : C 113 : IF(IF5.NE.NTROU)THEN 114 : DO IE4=IF5,NTROU-1 115 : TWORK(IE4)=TWORK(IE4+1) 116 : ENDDO 117 : ENDIF 118 : NTROU=NTROU-1 119 : SEGADJ,WWORK 120 : IE3=IE3-1 121 : GOTO 1 122 : C 123 : 10 CONTINUE 124 : C 125 : C FIN DU CAS A PLUSIEURS TROUS 126 : C 127 : ENDIF 128 : C 129 : C ON CONSIDERE MAINTENANT LE CONTOURS PRINCIPAL 130 : C 131 : WORK1=FWORK 132 : NPTO1=WORK1.DENS(/1) 133 : C 134 : C SI L'UN DES TROUS A UN POINT COMMUN, ON COHALESCE 135 : C 136 : C A) SIMULATION DE "DO 20 IE3=1,NTROU" AVEC NTROU VARIABLE 137 : C 138 : IE3=0 139 : 11 IE3=IE3+1 140 : IF(IE3.GT.NTROU)GOTO 20 141 : WORK2=TWORK(IE3) 142 : NPTO2=WORK2.DENS(/1) 143 : C 144 : C B) BOUCLE SUR LES POINTS DE WORK1 QUE L'ON CHARGE DANS XY 145 : C 146 : DO IE4=1,NPTO1 147 : IPO1=IE4 148 : XY(1)=WORK1.XYC(1,IE4) 149 : XY(2)=WORK1.XYC(2,IE4) 149 : CALL J3NOCO(XY,WORK2.XYC,NPTO2,TOL,IPO2) 150 : IF(IPO2.NE.0)GOTO 12 151 : ENDDO 152 : C 153 : GOTO 11 154 : C 155 : C C) COHALESCENCE DU TROU WORK2 AVEC WORK1 156 : C 157 : 12 NPTO=NPTO1+NPTO2 158 : SEGADJ,WORK1 159 : DO IE4=NPTO,IPO1+NPTO2,-1 160 : WORK1.DENS(IE4)=WORK1.DENS(IE4-NPTO2) 161 : WORK1.XYC(1,IE4)=WORK1.XYC(1,IE4-NPTO2) 162 : WORK1.XYC(2,IE4)=WORK1.XYC(2,IE4-NPTO2) 163 : ENDDO 164 : DO IE4=IPO1,IPO1+NPTO2-1 165 : JE4=IE4-IPO1+IPO2 166 : IF(JE4.GT.NPTO2)JE4=JE4-NPTO2 167 : WORK1.DENS(IE4)=WORK2.DENS(JE4) 168 : WORK1.XYC(1,IE4)=WORK2.XYC(1,JE4) 169 : WORK1.XYC(2,IE4)=WORK2.XYC(2,JE4) 170 : ENDDO 171 : C 172 : C D) SUPPRESSION DE WORK2 173 : C 174 : SEGSUP,WORK2 175 : C 176 : C E) ON REPASSE DANS LA MOULINETTE EN REORGANISANT TWORK 177 : C 178 : IF(IE3.NE.NTROU)THEN 179 : DO IE4=IE3,NTROU-1 180 : TWORK(IE4)=TWORK(IE4+1) 181 : ENDDO 182 : ENDIF 183 : NTROU=NTROU-1 184 : SEGADJ,WWORK 185 : IE3=IE3-1 186 : GOTO 11 187 : C 188 : 20 CONTINUE 189 : C 190 : C FIN DU CAS A TROU 191 : C 192 : IF(IIMPI.EQ.1790)THEN 193 : WRITE(IOIMP,*)'J3SURF: FACE APRES TRAITEMENT' 193 : CALL J3LIWW(WWORK) 194 : ENDIF 195 : ENDIF 196 : C 197 : C FIN BOUCLE FACE 198 : C 199 : ENDDO 200 : C 201 : C FIN BOUCLE BLOCK 202 : C 203 : ENDDO 204 : C 205 : RETURN 206 : END 207 : 208 :
© Cast3M 2003 - All rights reserved.
Disclaimer