1 : C COUTUR SOURCE PV 07/11/23 21:16:15 5978 2 : C CE SOUS PROGRAMME EFFECTUE LA COUTURE ENTRE DEUX LIGNES 3 : C REPRIS DE COCO 4 : C 5 : SUBROUTINE COUTUR 6 : IMPLICIT INTEGER(I-N) 7 : implicit real*8 (a-h,o-z) 8 : -INC CCGEOME 9 : -INC CCOPTIO 10 : -INC SMELEME 11 : -INC SMCOORD 12 : DIMENSION ITPOIN(2),ITEST(0:15) 13 : CHARACTER*(8) ITMAIL 14 : DATA ITMAIL/'MAILLAGE'/ 15 : DISTA(A,B,C,D,E,F)=SQRT((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F)) 16 : DO 10 I=0,15 17 : 10 ITEST(I)=0 17 : CALL LIROBJ(ITMAIL,IPT1,1,IRETOU) 17 : CALL LIROBJ(ITMAIL,IPT2,0,ILIG2) 17 : IF (ILIG2.EQ.0) CALL LIROBJ('POINT ',IPO2,1,IRETOU) 18 : IF (IERR.NE.0) RETURN 19 : SEGACT IPT1 19 : IF (IPT1.LISOUS(/1).NE.0) CALL ERREUR(25) 20 : IF (IERR.NE.0) RETURN 21 : IF (KSURF(IPT1.ITYPEL).EQ.0) THEN 22 : DO 21 I=1,IPT1.NUM(/2) 23 : ITEST(IPT1.ICOLOR(I))=1 24 : 21 CONTINUE 25 : GOTO 1 26 : ENDIF 27 : NBREF=IPT1.LISREF(/1) 27 : IF (NBREF.EQ.0) CALL ERREUR(24) 27 : IF (NBREF.NE.4) CALL ERREUR(26) 28 : IF (IERR.NE.0) RETURN 29 : IPT3=IPT1.LISREF(1) 30 : SEGDES IPT1 30 : CALL INVERS(IPT3,IPT1) 31 : DO 11 I=1,IPT3.NUM(/2) 32 : ITEST(IPT3.ICOLOR(I))=1 33 : 11 CONTINUE 34 : SEGDES IPT3 35 : 1 CONTINUE 36 : IF (ILIG2.EQ.0) GOTO 3 37 : SEGACT IPT2 37 : IF (IPT2.LISOUS(/1).NE.0) CALL ERREUR(25) 38 : IF (IERR.NE.0) RETURN 39 : IF (KSURF(IPT2.ITYPEL).EQ.0) THEN 40 : DO 22 I=1,IPT2.NUM(/2) 41 : ITEST(IPT2.ICOLOR(I))=1 42 : 22 CONTINUE 43 : GOTO 2 44 : ENDIF 45 : NBREF=IPT2.LISREF(/1) 45 : IF (NBREF.EQ.0) CALL ERREUR(24) 45 : IF (NBREF.NE.4) CALL ERREUR(26) 46 : IF (IERR.NE.0) RETURN 47 : IPT3=IPT2.LISREF(1) 48 : SEGDES IPT2 49 : DO 12 I=1,IPT3.NUM(/2) 50 : ITEST(IPT3.ICOLOR(I))=1 51 : 12 CONTINUE 52 : IPT2=IPT3 53 : 2 CONTINUE 54 : C IPT1 ET IPT2 SONT LES DEUX LIGNES A COUDRE ELLES SONT DECRITES 55 : C DANS LE MEME SENS 56 : C ON VERIFIE D'ABORD LA COHERENCE DES TYPES D'ELEMENTS 56 : IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16) 57 : IF (IERR.NE.0) RETURN 58 : C ON CREE IPT3 QUI CONTIENT LE RESULTAT 59 : 3 CONTINUE 60 : ICHCOL=-1 61 : DO 13 I=0,15 62 : IF (ITEST(I).EQ.1) THEN 63 : IF (ICHCOL.EQ.-1) THEN 64 : ICHCOL=I 65 : ELSE 66 : ICHCOL=ITABM(ICHCOL,I) 67 : ENDIF 68 : ENDIF 69 : 13 CONTINUE 70 : NBELE1=IPT1.NUM(/2) 71 : NBELE2=0 72 : NBREF=3 73 : IF (ILIG2.EQ.0) GOTO 4 74 : NBREF=4 75 : NBELE2=IPT2.NUM(/2) 76 : 4 CONTINUE 77 : NBELEM=NBELE1+NBELE2 78 : NBNN=3 79 : NBSOUS=0 80 : SEGINI IPT3 81 : IPT3.ITYPEL=4 82 : IPT3.LISREF(1)=IPT1 83 : IF (ILIG2.EQ.0) GOTO 5 83 : CALL INVERS(IPT2,IPT4) 84 : IPT3.LISREF(3)=IPT4 85 : SEGDES IPT4 86 : C IL FAUR CREER LES BORDS LATERAUX 87 : 5 CONTINUE 88 : NBNN=2 89 : NBELEM=1 90 : NBSOUS=0 91 : NBREF=0 92 : SEGINI IPT4 93 : IPT4.ITYPEL=2 94 : IPT3.LISREF(2)=IPT4 95 : IPT4.NUM(1,1)=IPT1.NUM(IPT1.NUM(/1),NBELE1) 96 : IF (ILIG2.NE.0) IPT4.NUM(2,1)=IPT2.NUM(IPT2.NUM(/1),NBELE2) 97 : IF (ILIG2.EQ.0) IPT4.NUM(2,1)=IPO2 98 : SEGDES IPT4 99 : NBNN=2 100 : NBELEM=1 101 : NBSOUS=0 102 : NBREF=0 103 : SEGINI IPT4 104 : IPT4.ITYPEL=2 105 : IPT4.NUM(2,1)=IPT1.NUM(1,1) 106 : IF (ILIG2.EQ.0) GOTO 6 107 : IPT4.NUM(1,1)=IPT2.NUM(1,1) 108 : IPT3.LISREF(4)=IPT4 109 : GOTO 7 110 : 6 IPT4.NUM(1,1)=IPO2 111 : IPT3.LISREF(3)=IPT4 112 : 7 SEGDES IPT4 113 : LNUMEL=1 114 : NBNN=IPT1.NUM(/1) 115 : IF (ILIG2.EQ.0) GOTO 800 116 : CC 117 : C COUTURE AVEC DES TRIANGLES A 3 NOEUDS 118 : C IMAX = NUMERO DU DERNIER ELEMENT DU COTE 1 119 : C JMAX = NUMERO DU DERNIER ELEMENT DE LA COUTURE 120 : C 121 : SEGACT MCOORD 122 : IMAX = NBELE1 123 : JMAX = NBELE2 124 : NUMELG=0 125 : IEL1=1 126 : IEL2=1 127 : 100 I1=IPT1.NUM(1,IEL1) 128 : I2=IPT1.NUM(NBNN,IEL1) 129 : J1=IPT2.NUM(1,IEL2) 130 : J2=IPT2.NUM(NBNN,IEL2) 131 : 101 CONTINUE 132 : IREF1=(I1-1)*(IDIM+1) 133 : IREF2=(I2-1)*(IDIM+1) 134 : JREF1=(J1-1)*(IDIM+1) 135 : JREF2=(J2-1)*(IDIM+1) 136 : XI1=XCOOR(IREF1+1) 137 : YI1=XCOOR(IREF1+2) 138 : ZI1=XCOOR(IREF1+3) 139 : XI2=XCOOR(IREF2+1) 140 : YI2=XCOOR(IREF2+2) 141 : ZI2=XCOOR(IREF2+3) 142 : XJ1=XCOOR(JREF1+1) 143 : YJ1=XCOOR(JREF1+2) 144 : ZJ1=XCOOR(JREF1+3) 145 : XJ2=XCOOR(JREF2+1) 146 : YJ2=XCOOR(JREF2+2) 147 : ZJ2=XCOOR(JREF2+3) 148 : IF (IDIM.EQ.3) GOTO 200 149 : ZI1=0 150 : ZI2=0 151 : ZJ1=0. 152 : ZJ2=0. 153 : 200 CONTINUE 154 : A=DISTA(XI1,YI1,ZI1,XJ2,YJ2,ZJ2) 155 : B=DISTA(XJ1,YJ1,ZJ1,XI2,YI2,ZI2) 156 : IF(A.LE.B) GO TO 102 157 : CC 158 : C DIST(J1,I2) < DIST(I1,J2) 159 : C ON CREE LE TRIANGLE I1,I2,J1 160 : C 161 : NUMELG = NUMELG + 1 162 : IPT3.NUM(1,NUMELG) = I1 163 : IPT3.NUM(2,NUMELG) = I2 164 : IPT3.NUM(3,NUMELG) = J1 165 : INTERR(1)=NUMELG 165 : IF (I1.EQ.I2.OR.I1.EQ.J1.OR.I2.EQ.J1) CALL ERREUR(101) 166 : IF(IEL1.EQ.IMAX) GO TO 103 167 : IEL1=IEL1+1 168 : GO TO 100 169 : CC 170 : C PLUS DE POINT SUR LE COTE 1 = ON RELIE I2 AUX POINTS RESTANTS 171 : C DE LA COUTURE 172 : C 173 : 103 NUMELG = NUMELG + 1 174 : IPT3.NUM(1,NUMELG) = I2 175 : IPT3.NUM(2,NUMELG) = J2 176 : IPT3.NUM(3,NUMELG) = J1 177 : INTERR(1)=NUMELG 177 : IF (I2.EQ.J2.OR.I2.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101) 178 : IF(IEL2.EQ.JMAX) GO TO 150 179 : IEL2=IEL2+1 180 : J1=IPT2.NUM(1,IEL2) 181 : J2=IPT2.NUM(NBNN,IEL2) 182 : GO TO 103 183 : CC 184 : C DIST(J1,I2) > DIST(I1,J2) 185 : C ON CREE LE TRIANGLE I1,J2,J1 186 : C 187 : 102 NUMELG = NUMELG + 1 188 : IPT3.NUM(1,NUMELG) = I1 189 : IPT3.NUM(2,NUMELG) = J2 190 : IPT3.NUM(3,NUMELG) = J1 191 : INTERR(1)=NUMELG 191 : IF (I1.EQ.J2.OR.I1.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101) 192 : IF(IEL2.EQ.JMAX) GO TO 105 193 : IEL2=IEL2+1 194 : GOTO 100 195 : CC 196 : C PLUS DE POINT SUR LA COUTURE = ON RELIE J2 AUX POINTS RESTANTS 197 : C DU COTE 1 198 : C 199 : 105 NUMELG = NUMELG + 1 200 : IPT3.NUM(1,NUMELG) = I1 201 : IPT3.NUM(2,NUMELG) = I2 202 : IPT3.NUM(3,NUMELG) = J2 203 : INTERR(1)=NUMELG 203 : IF (I1.EQ.I2.OR.I1.EQ.J2.OR.I2.EQ.J2) CALL ERREUR(101) 204 : IF(IEL1.EQ.IMAX) GO TO 150 205 : IEL1=IEL1+1 206 : I1=IPT1.NUM(1,IEL1) 207 : I2=IPT1.NUM(NBNN,IEL1) 208 : GO TO 105 209 : 800 CONTINUE 210 : C ON EST DANS LE CAS FACILE OU ON RELIE IPT1 AVEC UN SEUL POINT 211 : DO 801 I=1,NBELE1 212 : IPT3.NUM(1,I)=IPT1.NUM(1,I) 213 : IPT3.NUM(2,I)=IPT1.NUM(NBNN,I) 214 : IPT3.NUM(3,I)=IPO2 215 : 801 CONTINUE 216 : 150 CONTINUE 217 : C OK C'EST FAIT EVENTUELLEMENT CONVERTIR LE TYPE D'ELEMENT 218 : IF (NBNN.EQ.2) ITY=4 219 : IF (NBNN.EQ.3) ITY=6 219 : CALL CHANGE(IPT3,ITY) 220 : SEGDES IPT1 221 : IF (ILIG2.NE.0) SEGDES IPT2 222 : IF (IERR.NE.0) RETURN 223 : SEGACT IPT3*MOD 224 : DO 14 I=1,IPT3.NUM(/2) 225 : 14 IPT3.ICOLOR(I)=ICHCOL 226 : SEGDES IPT3 226 : CALL ECROBJ(ITMAIL,IPT3) 227 : RETURN 228 : END 229 : 230 : 231 : 232 : 233 : 234 : 235 : 236 : 237 : 238 :
© Cast3M 2003 - All rights reserved.
Disclaimer