1 : C FERME SOURCE PV 07/10/05 21:15:48 5890 2 : C---------------------------------------------------------------------| 3 : C | 4 : LOGICAL FUNCTION FERME(KKK) 5 : C | 6 : C CETTE FONCTION LOGIQUE VERIFIE SI LE MAILLAGE DE SURFACE | 7 : C EST FERME. | 8 : C ELLE VERIFIE AUSSI LE SIGNE DU VOLUME INTERNE | 9 : C | 10 : C FERME EST VRAI SI LE MAILLAGE DE SURFACE EST FERME | 11 : C | 12 : C FERME EST FAUX SI LE MAILLAGE DE SURFACE EST OUVERT | 13 : C | 14 : C ELLE TENTE D'ORIENTER LES ELEME,TS TOUS PAREILS | 15 : C | 16 : C | 17 : C---------------------------------------------------------------------| 18 : C 19 : IMPLICIT INTEGER(I-N) 20 : IMPLICIT REAL*8(A-H,O-Z) 21 : -INC TDEMAIT 22 : -INC CCOPTIO 23 : C 24 : C WRITE(6,1000) 25 : C1000 FORMAT(' SUBROUTINE FERME') 26 : C 27 : IBID =KKK 28 : IF (NFACET.EQ.0) GOTO 301 29 : DO 90 I=1,NFACET 30 : IFAT(I)=0 31 : IFUT(I)=0 32 : 90 CONTINUE 33 : IFC=1 34 : IFAT(1)=1 35 : IFUT(1)=1 36 : DO 100 I=1,NFACET 37 : IF=IFAT(I) 38 : IF (IF.EQ.0) GOTO 200 39 : DO 110 I1=1,4 40 : J1=NFC(I1,IF) 41 : NB=0 42 : NBPA=0 43 : IF (J1.EQ.0) GOTO 100 44 : J2=ISUCC(IF,J1) 45 : IFJ2=0 46 : DO 120 K=1,40 47 : JF=NPF(K,J1) 48 : IF (JF.EQ.0) GOTO 130 49 : IF (JF.EQ.IF) GOTO 120 50 : IF (ISUCC(JF,J1).EQ.J2) THEN 51 : * RETOURNER JF 52 : IFJ2=1 53 : IF (IFUT(JF).EQ.1) GOTO 200 54 : NBJ=4 55 : IF (NFC(4,JF).EQ.0) NBJ=3 56 : DO 125 I2=1,NBJ/2 57 : NTEMP=NFC(NBJ+1-I2,JF) 58 : NFC(NBJ+1-I2,JF)=NFC(I2,JF) 59 : NFC(I2,JF)=NTEMP 60 : 125 CONTINUE 61 : IFC=IFC+1 62 : IFAT(IFC)=JF 63 : IFUT(JF)=1 64 : ENDIF 65 : IF (IPRED(JF,J1).EQ.J2) THEN 66 : IFJ2=1 67 : IF (IFUT(JF).EQ.1) GOTO 120 68 : IFC=IFC+1 69 : IFAT(IFC)=JF 70 : IFUT(JF)=1 71 : ENDIF 72 : 120 CONTINUE 73 : 130 CONTINUE 74 : IF(IFJ2.EQ.0) GOTO 200 75 : 110 CONTINUE 76 : 100 CONTINUE 77 : IF (IFC.NE.NFACET) GOTO 200 78 : C 79 : FERME=.TRUE. 80 : C VERIFICATION DU SIGNE 81 : VOL=0. 82 : DO 300 IF=1,NFACET 83 : I1=NFC(1,IF) 84 : I2=NFC(2,IF) 85 : I3=NFC(3,IF) 86 : VOL=VOL-(XYZ(1,I1)*(XYZ(2,I2)*XYZ(3,I3)-XYZ(3,I2)*XYZ(2,I3)) 87 : # + XYZ(2,I1)*(XYZ(3,I2)*XYZ(1,I3)-XYZ(1,I2)*XYZ(3,I3)) 88 : # + XYZ(3,I1)*(XYZ(1,I2)*XYZ(2,I3)-XYZ(2,I2)*XYZ(1,I3))) 89 : I4=NFC(4,IF) 90 : IF (I4.EQ.0) GOTO 300 91 : VOL=VOL-(XYZ(1,I3)*(XYZ(2,I4)*XYZ(3,I1)-XYZ(3,I4)*XYZ(2,I1)) 92 : # + XYZ(2,I3)*(XYZ(3,I4)*XYZ(1,I1)-XYZ(1,I4)*XYZ(3,I1)) 93 : # + XYZ(3,I3)*(XYZ(1,I4)*XYZ(2,I1)-XYZ(2,I4)*XYZ(1,I1))) 94 : 300 CONTINUE 95 : 301 CONTINUE 96 : FERME=.TRUE. 97 : IF (VOL.LT.0.) GOTO 220 98 : GOTO 400 99 : C 100 : 200 FERME=.FALSE. 101 : WRITE(6,1010)J1,J2,IF,JF 102 : 1010 FORMAT(' PROBLEME FERME ARETE ',2I5,' FACETTES ',2I5) 103 : C 104 : RETURN 105 : 220 CONTINUE 106 : * TOUT RETOURNER 107 : DO 310 JF=1,NFACET 108 : NBJ=4 109 : IF (NFC(4,JF).EQ.0) NBJ=3 110 : DO 320 I2=1,NBJ/2 111 : NTEMP=NFC(NBJ+1-I2,JF) 112 : NFC(NBJ+1-I2,JF)=NFC(I2,JF) 113 : NFC(I2,JF)=NTEMP 114 : 320 CONTINUE 115 : 310 CONTINUE 116 : 400 CONTINUE 117 : * REMETTRE IFAT A ZERO 118 : DO 401 I=1,NFACET 119 : IFAT(I)=I 120 : IFUT(I)=I 121 : 401 CONTINUE 122 : RETURN 123 : END 124 : 125 :
© Cast3M 2003 - All rights reserved.
Disclaimer