1 : C TETRA2 SOURCE FANDEUR 13/01/29 21:16:33 7683 2 : C---------------------------------------------------------------------| 3 : C | 4 : SUBROUTINE TETRA2(II,JJ,IF1,IF2,IGAGNE,IPTT) 5 : C | 6 : C CETTE SUBROUTINE TENTE DE CREER DEUX TETRAEDRES A PARTIR | 7 : C DES 2 TRIANGLES IF1 ET IF2. | 8 : C | 9 : C - IGAGNE=1 EN CAS DE SUCCES | 10 : C - IGAGNE=0 EN CAS D'ECHEC | 11 : C | 12 : C---------------------------------------------------------------------| 13 : C 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8 (A-H,O-Z) 16 : -INC TDEMAIT 17 : -INC CCOPTIO 18 : LOGICAL REPONS,FACET,SOLTET,DIAGO,IN2,VERDIV,IN 19 : C 20 : if (iptt.gt.nptmax) then 21 : write (6,*) ' tetra2 iptt nptmax ',iptt,nptmax 22 : stop 16 23 : endif 24 : nfcini=nfcmax 25 : ip1=0 26 : ip2=0 27 : N3=0 28 : N4=0 29 : N5=0 30 : N6=0 31 : N7=0 32 : ICTF=0 33 : ICTV=0 34 : ipas=0 35 : ipin = 0 36 : C 37 : * IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN 38 : * write (6,*) ' tetra2 test in2 echoue ',ii,jj,iptt 39 : * RETURN 40 : * ENDIF 41 : IP=IPRED(IF1,II) 42 : JP=ISUCC(IF2,II) 43 : * CREATION FACETTE PREMIER ELEMENT 44 : * recherche existence de la face 45 : IF3=IFACE3(ii,iptt,ip) 46 : * IF (IF3.ne.0) write (6,*) ' tetra2 if3 assimilee ',ii,iptt,ip 47 : IF (IF3.eq.0) THEN 48 : nfcmax=nfcmax+1 49 : if3=nfcmax 50 : NFC(1,IF3)=ii 51 : NFC(2,IF3)=iptt 52 : NFC(3,IF3)=ip 53 : NFC(4,IF3)=0 54 : N3=IF3 55 : elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then 56 : * write (6,*) ' tetra2 probleme facette if3 ',if3 57 : nfcmax=nfcini 58 : return 59 : endif 60 : * recherche existence de la face 61 : IF4=IFACE3(jj,ip,iptt) 62 : * IF (IF4.ne.0) write (6,*) ' tetra2 if4 assimilee',jj,ip,iptt 63 : IF (IF4.eq.0) THEN 64 : NFCMAX=NFCMAX+1 65 : IF4=NFCMAX 66 : NFC(1,IF4)=jj 67 : NFC(2,IF4)=ip 68 : NFC(3,IF4)=iptt 69 : NFC(4,IF4)=0 70 : N4=IF4 71 : elseif (NFC(4,if4).ne.0.or.ipred(if4,jj).ne.ip) then 72 : * write (6,*) ' tetra2 probleme facette if4 ',if4 73 : nfcmax=nfcini 74 : return 75 : endif 76 : * creation facette commune (necessaire pour faire les verification) 77 : IF7=IFACE3(ii,jj,iptt) 78 : * IF (IF7.ne.0) write(6,*)'tetra2 facette if7 existe deja => echec' 79 : * IF (IF7.ne.0) THEN 80 : * nfcmax=nfcini 81 : * return 82 : * endif 83 : * IF (IF7.ne.0) write (6,*) ' tetra2 if7 assimilee',jj,ip,iptt 84 : IF (IF7.eq.0) THEN 85 : NFCMAX=NFCMAX+1 86 : IF7=NFCMAX 87 : NFC(1,IF7)=ii 88 : NFC(2,IF7)=jj 89 : NFC(3,IF7)=iptt 90 : NFC(4,IF7)=0 91 : N7=IF7 92 : elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ii) then 93 : * write (6,*) ' tetra2 probleme facette if7 ',if7 94 : nfcmax=nfcini 95 : return 96 : endif 97 : * nfcmoi=nfcmax si on veut garder le 2eme element 98 : nfcmoi=nfcini 99 : * CREATION FACETTES 2eme element 100 : * recherche existence de la face 101 : IF5=IFACE3(ii,jp,iptt) 102 : * IF (IF5.ne.0) write (6,*) ' tetra2 if5 assimilee',ii,jp,iptt 103 : IF (IF5.eq.0) THEN 104 : NFCMAX=NFCMAX+1 105 : IF5=NFCMAX 106 : NFC(1,IF5)=ii 107 : NFC(2,IF5)=JP 108 : NFC(3,IF5)=iptt 109 : NFC(4,IF5)=0 110 : N5=IF5 111 : elseif (NFC(4,if5).ne.0.or.ipred(if5,ii).ne.jp) then 112 : * write (6,*) ' tetra2 probleme facette if5 ',if5 113 : nfcmax=nfcini 114 : return 115 : endif 116 : * recherche existence de la face 117 : IF6=IFACE3(jj,iptt,jp) 118 : * IF (IF6.ne.0) write (6,*) ' tetra2 if6 assimilee',jj,iptt,jp 119 : IF (IF6.eq.0) THEN 120 : NFCMAX=NFCMAX+1 121 : IF6=NFCMAX 122 : NFC(1,IF6)=jj 123 : NFC(2,IF6)=iptt 124 : NFC(3,IF6)=jp 125 : NFC(4,IF6)=0 126 : N6=IF6 127 : elseif (NFC(4,if6).ne.0.or.ipred(if6,jj).ne.iptt) then 128 : * write (6,*) ' tetra2 probleme facette if6 ',if6 129 : nfcmax=nfcini 130 : return 131 : endif 132 : * si necessaire verification diago 133 : * on se fait aussi une petite verif de longueur 134 : IF (N3.NE.0.AND.N5.NE.0) then 135 : IF (DIAGO(iptt,ii,diacrd)) GOTO 274 136 : DNORM=(XYZ(1,IPTT)-XYZ(1,II))**2 137 : # +(XYZ(2,IPTT)-XYZ(2,II))**2 138 : # +(XYZ(3,IPTT)-XYZ(3,II))**2 139 : DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,II) 140 : IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 141 : ENDIF 142 : IF (N4.NE.0.AND.N6.NE.0) then 143 : IF (DIAGO(iptt,jj,diacrd)) GOTO 274 144 : DNORM=(XYZ(1,IPTT)-XYZ(1,JJ))**2 145 : # +(XYZ(2,IPTT)-XYZ(2,JJ))**2 146 : # +(XYZ(3,IPTT)-XYZ(3,JJ))**2 147 : DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JJ) 148 : IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 149 : ENDIF 150 : IF (N3.NE.0.AND.N4.NE.0) then 151 : IF (DIAGO(iptt,ip,diacrd)) GOTO 274 152 : DNORM=(XYZ(1,IPTT)-XYZ(1,IP))**2 153 : # +(XYZ(2,IPTT)-XYZ(2,IP))**2 154 : # +(XYZ(3,IPTT)-XYZ(3,IP))**2 155 : DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,IP) 156 : IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 157 : ENDIF 158 : IF (N3.NE.0) THEN 159 : * TEST DU POINT MILIEU de if3 160 : DO 242 I=1,4 161 : XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if3))+XYZ(I,nfc(2,if3))+ 162 : > XYZ(I,nfc(3,if3)))/3 163 : 242 CONTINUE 163 : * call vcrit(nptmax+3) 163 : * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) 164 : * IF (IOK.EQ.0) goto 277 165 : ENDIF 166 : IF (N4.NE.0) THEN 167 : * TEST DU POINT MILIEU de if4 168 : DO 243 I=1,4 169 : XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if4))+XYZ(I,nfc(2,if4))+ 170 : > XYZ(I,nfc(3,if4)))/3 171 : 243 CONTINUE 171 : * call vcrit(nptmax+3) 171 : * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) 172 : * IF (IOK.EQ.0) goto 277 173 : ENDIF 174 : IF (N5.NE.0) THEN 175 : * TEST DU POINT MILIEU de if7 176 : DO 244 I=1,4 177 : XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if7))+XYZ(I,nfc(2,if7))+ 178 : > XYZ(I,nfc(3,if7)))/3 179 : 244 CONTINUE 179 : * call vcrit(nptmax+3) 179 : * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) 180 : * IF (IOK.EQ.0) goto 277 181 : ENDIF 182 : goto 276 183 : 274 continue 184 : nfcmax=nfcini 185 : * write (6,*) ' tetra2 echec diago 1 ',ii,jj,ip,jp,iptt 186 : return 187 : 275 continue 188 : nfcmax=nfcini 189 : * write (6,*) ' tetra2 echec longueur 1' 190 : return 191 : 277 continue 192 : nfcmax=nfcini 193 : * write (6,*) ' tetra2 dist pt milieu' 194 : return 195 : 278 continue 196 : nfcmax=nfcini 197 : * write (6,*) ' tetra2 gl pt milieu' 198 : return 199 : 276 continue 200 : C 200 : CALL REPSUB(IF1) 200 : CALL REPSUB(IF3) 200 : CALL REPSUB(IF4) 200 : CALL REPSUB(IF7) 201 : * verification du premier element 202 : IF (.NOT.SOLTET(IF1,IF3,IF4,IF7,IPIN)) then 203 : * write (6,*) 'tetra2 soltet invalide - 1',ii,ip,iptt,jj 204 : GOTO 160 205 : ENDIF 206 : IF (.NOT.FACET(IF3)) then 207 : * write(6,*) ' tetra2 facet if3 invalide' 208 : GOTO 160 209 : ENDIF 210 : IF (.NOT.FACET(IF4)) then 211 : * write(6,*) ' tetra2 facet if4 invalide' 212 : GOTO 160 213 : ENDIF 214 : IF (.NOT.FACET(IF7)) then 215 : * write(6,*) ' tetra2 facet if7 invalide' 216 : GOTO 160 217 : ENDIF 218 : * 219 : IF (N5.NE.0.AND.N6.NE.0) then 220 : IF (DIAGO(iptt,jp,diacrd)) GOTO 284 221 : DNORM=(XYZ(1,IPTT)-XYZ(1,JP))**2 222 : # +(XYZ(2,IPTT)-XYZ(2,JP))**2 223 : # +(XYZ(3,IPTT)-XYZ(3,JP))**2 224 : DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JP) 225 : IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 285 226 : ENDIF 227 : IF (N5.NE.0) THEN 228 : * TEST DU POINT MILIEU de if5 229 : DO 245 I=1,4 230 : XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if5))+XYZ(I,nfc(2,if5))+ 231 : > XYZ(I,nfc(3,if5)))/3 232 : 245 CONTINUE 232 : * call vcrit(nptmax+3) 232 : * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) 233 : * IF (IOK.EQ.0) goto 287 234 : ENDIF 235 : IF (N6.NE.0) THEN 236 : * TEST DU POINT MILIEU de if6 237 : DO 246 I=1,4 238 : XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if6))+XYZ(I,nfc(2,if6))+ 239 : > XYZ(I,nfc(3,if6)))/3 240 : 246 CONTINUE 240 : * call vcrit(nptmax+3) 240 : * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) 241 : * IF (IOK.EQ.0) goto 287 242 : ENDIF 243 : goto 286 244 : 284 continue 245 : nfcmax=nfcmoi 246 : * write (6,*) ' tetra2 echec diago 2 ',ii,jj,ip,jp,iptt 247 : goto 160 248 : 285 continue 249 : nfcmax=nfcmoi 250 : * write (6,*) ' tetra2 echec longueur 2' 251 : goto 160 252 : 287 continue 253 : nfcmax=nfcmoi 254 : * write (6,*) ' tetra2 echec dist 2' 255 : goto 160 256 : 288 continue 257 : nfcmax=nfcmoi 258 : * write (6,*) ' tetra2 echec gl 2' 259 : goto 160 260 : 286 continue 260 : CALL REPSUB(IF2) 260 : CALL REPSUB(IF5) 260 : CALL REPSUB(IF6) 260 : CALL REPSUB(IF7) 261 : * verification du deuxieme element element 262 : IF (.NOT.SOLTET(IF2,IF5,IF6,IF7,IPIN)) then 263 : * write (6,*) 'tetra2 soltet invalide - 2 ',ii,jp,iptt,jj 264 : GOTO 165 265 : endif 266 : IF (.NOT.FACET(IF5)) then 267 : * write(6,*) ' tetra2 facet if5 invalide' 268 : GOTO 165 269 : ENDIF 270 : IF (.NOT.FACET(IF6)) then 271 : * write(6,*) ' tetra2 facet if6 invalide' 272 : GOTO 165 273 : ENDIF 274 : * CREATION premier ELEMENT 275 : IGAGNE=1 276 : NVOL=NVOL+1 277 : IVOL(9,NVOL)=25 278 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 279 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 280 : IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL 281 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL 282 : IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL 283 : IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL 284 : DO 254 I=1,3 285 : IVOL(I,NVOL)=NFC(I,IF1) 286 : 254 CONTINUE 287 : IVOL(4,NVOL)=IPTT 288 : qual=qualt(ii,jj,ip,iptt) 289 : if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual, 290 : > (ivol(i,nvol),i=1,4) 291 : 1100 format (' TETRA2 ',i5,i6,f8.4,4i6) 292 : * CREATION deuxieme ELEMENT 293 : NVOL=NVOL+1 294 : IVOL(9,NVOL)=25 295 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 296 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 297 : IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL 298 : IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL 299 : IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL 300 : IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL 301 : DO 256 I=1,3 302 : IVOL(I,NVOL)=NFC(I,IF2) 303 : 256 CONTINUE 304 : IVOL(4,NVOL)=IPTT 305 : qual=qualt(jj,ii,jp,iptt) 306 : if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual, 307 : > (ivol(i,nvol),i=1,4) 308 : IGAGNE=1 309 : RETURN 310 : 165 continue 310 : CALL REPSUB(IF7) 310 : CALL REPSUB(IF6) 310 : CALL REPSUB(IF5) 310 : CALL REPSUB(IF2) 311 : nfcmax=nfcmoi 312 : * if (nptmax.eq.iptt) 313 : * > write (6,*) ' tetra2 echec 2eme element' 314 : * return on ne fait aucun element 315 : 160 continue 315 : CALL REPSUB(IF7) 315 : CALL REPSUB(IF4) 315 : CALL REPSUB(IF3) 315 : CALL REPSUB(IF1) 316 : nfcmax=nfcini 317 : return 318 : RETURN 319 : END 320 : 321 : 322 :
© Cast3M 2003 - All rights reserved.
Disclaimer