1 : C DEGSUR SOURCE CHAT 05/01/12 22:41:07 5004 2 : C ETUDIE S'IL Y A LIEU DE DEGENERER DES ELEMENTS DANS LE CAS D'UNE 3 : C SURFACE ENGENDRE PAR ROTATION (POINT SUR L'AXE APPARTENANT A LA 4 : C LIGNE 5 : C 6 : SUBROUTINE DEGSUR(MELEME,IP1,IP2) 7 : IMPLICIT INTEGER(I-N) 8 : -INC SMELEME 9 : -INC CCOPTIO 10 : SEGMENT IDEG(NBNNL,NBELX) 11 : DIMENSION IREF(4) 12 : C MELEME EST ACTIF ET DOIT L'ETRE EN RETOUR 13 : SEGACT MELEME 14 : IF (IDIM.EQ.2) IP2=IP1 15 : IP1R=IP1 16 : IP2R=IP2 17 : IPT1=LISREF(1) 18 : IPT3=LISREF(3) 19 : SEGACT IPT1,IPT3 20 : C Y A T IL LIEU DE DEGENERER DES ELEMENTS. ON EXAMINE LE COTE INITIAL 21 : C PAR RAPPORT AUX POINTS DEFINISSANT L'AXE DE LA ROTATION 22 : C ON EN PROFITE POUR IDENTIFIER LES POINTS DU COTE 3 CONCERNES 23 : C SI LA DEGENERESCENCE CE FAIT SUR UNE EXTREMITE ON SUPPRIME LE COTE 24 : C CORRESPONDANT 25 : NREF=4 26 : IREF(1)=LISREF(1) 27 : IREF(2)=LISREF(2) 28 : IREF(3)=LISREF(3) 29 : IREF(4)=LISREF(4) 30 : NBNN=IPT1.NUM(/1) 31 : NBNNL=NBNN 32 : IPAS=NBNN-1 33 : NBELX=IPT1.NUM(/2) 34 : SEGINI IDEG 35 : DO 5 I=1,NBNNL 36 : DO 5 J=1,NBELX 37 : IDEG(I,J)=0 38 : 5 CONTINUE 39 : NBDEG=0 40 : DO 10 J=1,NBELX 41 : DO 10 I=1,NBNN,IPAS 42 : IP=IPT1.NUM(I,J) 43 : IF (IP.NE.IP1R.AND.IP.NE.IP2R) GOTO 10 44 : IDEG(I,J)=IP 45 : NBDEG=NBDEG+1 46 : IPT3.NUM(NBNN+1-I,NBELX+1-J)=IP 47 : IF (I.NE.1.OR.J.NE.1) GOTO 11 48 : IPT4=IREF(4) 49 : SEGSUP IPT4 50 : NREF=3 51 : GOTO 10 52 : 11 IF (I.NE.NBNN.OR.J.NE.NBELX) GOTO 10 53 : IPT2=IREF(2) 54 : SEGSUP IPT2 55 : NREF=NREF-1 56 : IREF(2)=IREF(3) 57 : IREF(3)=IREF(4) 58 : 10 CONTINUE 59 : SEGDES IPT1,IPT3 60 : IF (NBDEG.NE.0) GOTO 20 61 : SEGSUP IDEG 62 : RETURN 63 : 20 CONTINUE 64 : NBELI=NUM(/2) 65 : NBELY=NBELI/NBELX 66 : IPT1=MELEME 67 : C IPT1 OBJET INITIAL MELEME OBJET FINAL 68 : C IPT3 TRIANGLES FINAUX IPT4 QUADRANGLES FINAUX 69 : IF (ITYPEL.LE.6) GOTO 500 70 : C CAS DES QUADRILATERES 71 : NBELET=NBDEG*NBELY 72 : NBELEQ=NBELI-NBELET 73 : IF (NBELEQ.EQ.0) GOTO 50 74 : NBELEM=NBELEQ 75 : NBSOUS=0 76 : NBREF=0 77 : NBNNQ=IPT1.NUM(/1) 78 : NBNN=NBNNQ 79 : SEGINI IPT4 80 : IPT4.ITYPEL=IPT1.ITYPEL 81 : NBELEM=NBELET 82 : NBNNT=(NBNNQ*3)/4 83 : NBNN=NBNNT 84 : SEGINI IPT3 85 : IPT3.ITYPEL=IPT1.ITYPEL-4 86 : NBSOUS=2 87 : NBREF=NREF 88 : NBNN=0 89 : NBELEM=0 90 : SEGINI MELEME 91 : LISOUS(1)=IPT3 92 : LISOUS(2)=IPT4 93 : DO 40 I=1,NREF 94 : LISREF(I)=IREF(I) 95 : 40 CONTINUE 96 : GOTO 70 97 : 50 CONTINUE 98 : NBELEM=NBELET 99 : NBNNT=(IPT1.NUM(/1)*3)/4 100 : NBNN=NBNNT 101 : NBSOUS=0 102 : NBREF=NREF 103 : SEGINI IPT3 104 : MELEME=IPT3 105 : C EVENTUELS PROBLEMES D'OPTIMISATION 106 : IPT4=IPT3 107 : IPT3.ITYPEL=IPT1.ITYPEL-4 108 : DO 60 I=1,NREF 109 : IPT3.LISREF(I)=IREF(I) 110 : 60 CONTINUE 111 : 70 CONTINUE 112 : C IL FAUT MAINTENANT REMPLIR CORRECTEMENT IPT3 ET IPT4 113 : IL3=0 114 : IL4=0 115 : DO 100 K=1,NBELY 116 : DO 100 JJ=1,IPT1.NUM(/2) 117 : J=JJ+(K-1)*NBELY 118 : IF (IDEG(1,JJ).EQ.0) GOTO 105 119 : C ON DEGENERE LE PREMIER POINT 120 : IL3=IL3+1 121 : DO 101 I=1,NBNNT 122 : IPT3.NUM(I,IL3)=IPT1.NUM(I,J) 123 : 101 CONTINUE 124 : IPT3.ICOLOR(IL3)=IPT1.ICOLOR(J) 125 : GOTO 100 126 : 105 IF (IDEG(NBNNL,JJ).EQ.0) GOTO 110 127 : C OM DEGENERE LE DEUXIEME POINT 128 : IL3=IL3+1 129 : IF (NBNNT.NE.3) GOTO 107 130 : DO 106 I=1,3 131 : II=I 132 : IF (II.EQ.3) II=4 133 : IPT3.NUM(I,IL3)=IPT1.NUM(II,J) 134 : 106 CONTINUE 135 : IPT3.ICOLOR(IL3)=IPT1.ICOLOR(J) 136 : GOTO 100 137 : 107 CONTINUE 138 : DO 108 I=1,6 139 : II=I 140 : IF (II.GT.3) II=I+2 141 : IPT3.NUM(I,IL3)=IPT1.NUM(II,J) 142 : 108 CONTINUE 143 : IPT3.ICOLOR(IL3)=IPT1.ICOLOR(J) 144 : GOTO 100 145 : 110 CONTINUE 146 : C ON RECOPIE LE QUADRILATERE 147 : IL4=IL4+1 148 : DO 111 I=1,NBNNQ 149 : IPT4.NUM(I,IL4)=IPT1.NUM(I,J) 150 : 111 CONTINUE 151 : IPT4.ICOLOR(IL4)=IPT1.ICOLOR(J) 152 : GOTO 100 153 : 100 CONTINUE 154 : SEGDES IPT4,IPT3 155 : 500 CONTINUE 156 : RETURN 157 : END 158 :
© Cast3M 2003 - All rights reserved.
Disclaimer