1 : C PRISM1 SOURCE PV 07/10/08 21:15:12 5896 2 : C---------------------------------------------------------------------| 3 : C | 4 : SUBROUTINE PRISM1(II,JJ,IF1,IF2,IGAGNE) 5 : C | 6 : C CETTE SUBROUTINE TENTE DE CREER UN PRISME A PARTIR | 7 : C DES QUADRANGLES IF1 ET IF2. | 8 : C - IGAGNE=1 EN CAS DE SUCCES | 9 : C - IGAGNE=0 EN CAS D'ECHEC | 10 : C | 11 : C---------------------------------------------------------------------| 12 : C 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : -INC TDEMAIT 16 : -INC CCOPTIO 17 : LOGICAL REPONS,FACET,SOLPRI,SOLPYR,SOLTET,DIAGO,IN,PLAN 18 : C 19 : * WRITE(6,*) ' PRISM1 ',ii,jj,if1,if2 20 : C 21 : * write (6,*) ' liste des facettes restantes ' 22 : * DO 444 I=1,NFCMAX 23 : * IF (IFAT(I).EQ.1) GOTO 444 24 : * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I) 25 : *444 CONTINUE 26 : N3=0 27 : N4=0 28 : N5=0 29 : ICTF=0 30 : ICTV=0 31 : C 32 : C RECHERCHE DE LA FACETTE IF3 33 : C --------------------------- 34 : C 35 : IF3=IFACE3(ISUCC(IF2,II),II,IPRED(IF1,II)) 36 : * IF (IF3.NE.0) WRITE(6,1010)IF3 37 : 1010 FORMAT(' ** IF3=',I3) 38 : C 39 : IF (IF3.NE.0) THEN 40 : * si if3 dans le mauvais sens rien a faire 41 : if (isucc(if3,ii).ne.iPRED(IF1,II)) then 42 : write (6,*) ' prism1 face a l''envers if3 ' 43 : return 44 : endif 45 : N3=1 46 : IF(NFC(4,IF3).NE.0) N3=2 47 : C FACE PAS TRIANGULAIRE 48 : ENDIF 49 : C 50 : C RECHERCHE DE LA FACETTE IF4 51 : C --------------------------- 52 : C 53 : IF4=IFACE3(IPRED(IF2,JJ),JJ,ISUCC(IF1,JJ)) 54 : * IF (IF4.NE.0) WRITE(6,1020)IF4 55 : 1020 FORMAT(' ** IF4=',I3) 56 : C 57 : IF (IF4.NE.0) THEN 58 : * si if4 dans le mauvais sens rien a faire 59 : if (isucc(if4,jj).ne.iPRED(IF2,jj)) then 60 : write (6,*) ' prism1 face a l''envers if4 ' 61 : return 62 : endif 63 : N4=1 64 : IF(NFC(4,IF4).NE.0) N4=2 65 : C FACE PAS TRIANGULAIRE 66 : ENDIF 67 : IF (N3.EQ.2.OR.N4.EQ.2) GOTO 9000 68 : C 69 : C 70 : C RECHERCHE DE LA FACETTE IF5 71 : C --------------------------- 72 : C 73 : IF5=IFACE4(ISUCC(IF1,JJ),IPRED(IF1,II), 74 : # ISUCC(IF2,II),IPRED(IF2,JJ)) 75 : * IF (IF5.NE.0) WRITE(6,1030) IF5 76 : 1030 FORMAT(' **IF5=',I3) 77 : IF (IF5.LT.0) GOTO 9000 78 : IF (IF5.NE.0) N5=1 79 : C 80 : C 81 : IF (DIAGO(IPRED(IF1,II),ISUCC(IF2,II),0.95d0)) GOTO 9000 82 : * DIAGONALE QUADRILATERE 83 : C 84 : IF (DIAGO(IPRED(IF2,JJ),ISUCC(IF1,JJ),0.95d0)) GOTO 9000 85 : * DIAGONALE QUADRILATERE 86 : C 87 : C 88 : C CONSTRUCTION DU PRISME 89 : C ---------------------- 90 : C 91 : IF (IF3.EQ.0) THEN 92 : C 93 : C CREATION DE LA FACETTE IF3 94 : C -------------------------- 95 : NFCMAX=NFCMAX+1 96 : IF3=NFCMAX 97 : ICTF=ICTF+1 98 : C 99 : NFC(1,IF3)=IPRED(IF1,II) 100 : NFC(2,IF3)=II 101 : NFC(3,IF3)=ISUCC(IF2,II) 102 : NFC(4,IF3)=0 103 : C 104 : ENDIF 105 : C 106 : C 107 : IF (IF4.EQ.0) THEN 108 : C 109 : C CREATION DE LA FACETTE IF4 110 : C -------------------------- 111 : NFCMAX=NFCMAX+1 112 : IF4=NFCMAX 113 : ICTF=ICTF+1 114 : C 115 : NFC(1,IF4)=JJ 116 : NFC(2,IF4)=ISUCC(IF1,JJ) 117 : NFC(3,IF4)=IPRED(IF2,JJ) 118 : NFC(4,IF4)=0 119 : C 120 : ENDIF 121 : C 122 : C 123 : IF (IF5.EQ.0) THEN 124 : C 125 : C CREATION DE LA FACETTE IF5 126 : C -------------------------- 127 : NFCMAX=NFCMAX+1 128 : IF5=NFCMAX 129 : ICTF=ICTF+1 130 : C 131 : NFC(1,IF5)=IPRED(IF2,JJ) 132 : NFC(2,IF5)=ISUCC(IF1,JJ) 133 : NFC(3,IF5)=IPRED(IF1,II) 134 : NFC(4,IF5)=ISUCC(IF2,II) 135 : C 136 : C 137 : ENDIF 138 : C 139 : C ON ENLEVE LES FACETTES IF1, IF2 ET IF3 140 : C -------------------------------------- 140 : CALL REPSUB(IF1) 140 : CALL REPSUB(IF2) 140 : CALL REPSUB(IF3) 140 : CALL REPSUB(IF4) 140 : CALL REPSUB(IF5) 141 : C 142 : C LE VOLUME CREE EST-IL VALIDE ? 143 : C ------------------------------ 144 : IF (.NOT.PLAN(IF5)) GOTO 160 145 : IF (.NOT.FACET(IF3)) GOTO 160 146 : IF (.NOT.FACET(IF4)) GOTO 160 147 : IF (.NOT.FACET(IF5)) GOTO 160 148 : IF (.NOT.SOLPRI(IF1,IF2,IF3,IF4,IF5)) GOTO 160 149 : * 150 : * VERIFICATION TAILLE 151 : IF (N3.EQ.0.AND.N5.EQ.0) THEN 152 : KF1=IPRED(IF1,II) 153 : KF2=ISUCC(IF2,II) 154 : DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2 155 : # +(XYZ(2,KF1)-XYZ(2,KF2))**2 156 : # +(XYZ(3,KF1)-XYZ(3,KF2))**2 157 : DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2) 158 : IF (DNORM.GT.DTEST) GOTO 160 159 : ENDIF 160 : IF (N4.EQ.0.AND.N5.EQ.0) THEN 161 : KF1=IPRED(IF2,JJ) 162 : KF2=ISUCC(IF1,JJ) 163 : DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2 164 : # +(XYZ(2,KF1)-XYZ(2,KF2))**2 165 : # +(XYZ(3,KF1)-XYZ(3,KF2))**2 166 : DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2) 167 : IF (DNORM.GT.DTEST) GOTO 160 168 : ENDIF 169 : * verification complementaire sur la facette if5 170 : if (n5.eq.0) then 171 : do 200 i=1,4 172 : xyz(i,nptmax+1)=0. 173 : do 210 j=1,4 174 : xyz(i,nptmax+1)=xyz(i,nptmax+1)+xyz(i,nfc(j,if5)) 175 : 210 continue 176 : xyz(i,nptmax+1)=xyz(i,nptmax+1)/4.d0 177 : 200 continue 177 : CALL DIST(nptmax+1,KP,GL,IOK,II,JJ,nfc(1,if5),nfc(2,if5), 178 : > nfc(3,if5),nfc(4,if5),0,0,0,0) 179 : if (iok.eq.0) write (6,*) ' prism1 echec dist' 180 : if (iok.eq.0) goto 160 181 : endif 182 : C 183 : C LE VOLUME CREE EST VALIDE | 184 : C --------------------------- 185 : C MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5 186 : C ------------------------------------------------ 187 : NVOL=NVOL+1 188 : IVOL(9,NVOL)=30 189 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 190 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 191 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 192 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 193 : IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL 194 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL 195 : IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL 196 : IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL 197 : IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL 198 : IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL 199 : IVOL(1,NVOL)=II 200 : IVOL(2,NVOL)=IPRED(IF1,II) 201 : IVOL(3,NVOL)=ISUCC(IF2,II) 202 : IVOL(4,NVOL)=JJ 203 : IVOL(5,NVOL)=ISUCC(IF1,JJ) 204 : IVOL(6,NVOL)=IPRED(IF2,JJ) 205 : C 206 : * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9) 207 : *1100 FORMAT(I4,4X,14I4) 208 : if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,6) 209 : 1100 FORMAT(' PRISM1 facettes ',i5,' pri6 ',8i5) 210 : C 211 : * DO 150 J=1,NPTMAX 212 : * WRITE(6,1110)J,(NPF(I,J),I=1,40) 213 : *1110 FORMAT(I4,4X,40I3) 214 : *150 CONTINUE 215 : C 216 : IGAGNE=1 217 : C 218 : RETURN 219 : C 220 : 160 CONTINUE 221 : C 222 : C LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT 223 : C CREEES. --------------------------------------------------------- 223 : CALL REPSUB(IF1) 223 : CALL REPSUB(IF2) 223 : CALL REPSUB(IF3) 223 : CALL REPSUB(IF4) 223 : CALL REPSUB(IF5) 224 : C 225 : NFCMAX=NFCMAX-ICTF 226 : C 227 : GOTO 9000 228 : 9000 CONTINUE 229 : * on va d'abord betement essayer de mettre 2 pyramides en rajoutant 230 : * un point 230 : call pyra3(II,JJ,IF1,IF2,IGAGNE) 231 : IF (IGAGNE.EQ.1) RETURN 231 : IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,IF3,IGAGNE) 232 : IF (IGAGNE.EQ.1) RETURN 232 : IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,IF4,IGAGNE) 233 : RETURN 234 : END 235 : 236 : 237 :
© Cast3M 2003 - All rights reserved.
Disclaimer