1 : C PRDIFF SOURCE MAUGIS 07/10/10 21:15:09 5889 2 : C INTERFACE ENTRE LA DIRECTIVE "DIFF" (DIFFERENCE SYMETRIQUE) ET LE 3 : C SOUS PROGRAMME OUEXCL 4 : C 5 : SUBROUTINE PRDIFF 6 : IMPLICIT INTEGER(I-N) 7 : -INC CCOPTIO 8 : -INC SMELEME 8 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 8 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 9 : IF (IERR.NE.0) RETURN 10 : SEGACT IPT1,IPT2 11 : IF (IPT1.LISOUS(/1).NE.0) GOTO 10 12 : IF (IPT2.LISOUS(/1).NE.0) GOTO 11 13 : 14 : C Deux maillages simples 15 : IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 1 16 : C Deux maillages simples de même type 17 : IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 1 18 : 19 : C---- Les deux maillages sont simples, de même type et même nombre de point par maille 20 : C 1) Les deux maillages sont identiques : résultat vide 21 : 22 : IF (IPT1.EQ.IPT2) THEN 23 : NBELEM=0 24 : NBNN=0 25 : NBREF=0 26 : NBSOUS=0 27 : SEGINI IPT3 28 : IPT3.ITYPEL = 1 29 : GOTO 1000 30 : ENDIF 31 : 31 : CALL OUEXCL(IPT1,IPT2,IPT3) 32 : IF (IERR.NE.0) RETURN 33 : 34 : C 2) le résultat est vide 35 : IF (IPT3.EQ.0) THEN 36 : NBELEM=0 37 : NBNN=0 38 : NBREF=0 39 : NBSOUS=0 40 : SEGINI IPT3 41 : IPT3.ITYPEL = 1 42 : GOTO 1000 43 : ENDIF 44 : 45 : C 3) le résultat est non vide 46 : GOTO 1000 47 : 48 : 49 : C Adjonction directe des deux sous-maillages simples de structure différente 50 : 1 CONTINUE 51 : NBELEM=0 52 : NBNN=0 53 : NBREF=0 54 : NBSOUS=2 55 : SEGINI IPT3 56 : IPT3.LISOUS(1)=IPT1 57 : IPT3.LISOUS(2)=IPT2 58 : GOTO 1000 59 : 60 : 10 IF (IPT2.LISOUS(/1).NE.0) GOTO 20 61 : GOTO 12 62 : 63 : C---- Un simple, l'autre complexe 64 : C On intervertit éventuellement pour que le premier soit le complexe 65 : 11 IP=IPT2 66 : IPT2=IPT1 67 : IPT1=IP 68 : 12 CONTINUE 69 : C IPT2 PAS DE SOUS-OBJETS IPT1 EN A 70 : DO 13 IS=1,IPT1.LISOUS(/1) 71 : IPT4=IPT1.LISOUS(IS) 72 : SEGACT IPT4 73 : IF (IPT2.NUM(/1).EQ.IPT4.NUM(/1)) THEN 74 : IF (IPT2.ITYPEL.EQ.IPT4.ITYPEL) GOTO 14 75 : ENDIF 76 : SEGDES IPT4 77 : 13 CONTINUE 78 : NBELEM=0 79 : NBNN=0 80 : NBREF=0 81 : NBSOU1=IPT1.LISOUS(/1) 82 : NBSOUS=NBSOU1+1 83 : SEGINI IPT3 84 : DO 15 IS=1,NBSOU1 85 : IPT3.LISOUS(IS)=IPT1.LISOUS(IS) 86 : 15 CONTINUE 87 : IPT3.LISOUS(NBSOUS)=IPT2 88 : GOTO 1000 89 : 14 IF (IPT2.EQ.IPT4) GOTO 17 89 : CALL OUEXCL(IPT2,IPT4,IPT5) 90 : if (ipt5.eq.0) goto 17 91 : SEGDES IPT4,IPT5 92 : IF (IERR.NE.0) RETURN 93 : 94 : NBSOUS=IPT1.LISOUS(/1) 95 : NBNN=0 96 : NBREF=0 97 : NBELEM=0 98 : SEGINI IPT3 99 : DO 16 IS2=1,NBSOUS 100 : IPT3.LISOUS(IS2)=IPT1.LISOUS(IS2) 101 : IF (IS.EQ.IS2) IPT3.LISOUS(IS2)=IPT5 102 : 16 CONTINUE 103 : GOTO 1000 104 : 105 : 17 SEGDES IPT4 106 : NBNN=0 107 : NBREF=0 108 : NBELEM=0 109 : NBSOUS=IPT1.LISOUS(/1)-1 110 : 111 : C-------- Cas d'un maillage vide --------------------------------- 112 : 113 : IF (NBSOUS.EQ.0) THEN 114 : NBELEM=0 115 : NBNN=0 116 : NBREF=0 117 : NBSOUS=0 118 : SEGINI IPT3 119 : IPT3.ITYPEL = 1 120 : GOTO 1000 121 : ENDIF 122 : 123 : SEGINI IPT3 124 : IS3=0 125 : DO 18 IS2=1,(NBSOUS + 1) 126 : IF (IS2.EQ.IS) GOTO 18 127 : IS3=IS3+1 128 : IPT3.LISOUS(IS3)=IPT1.LISOUS(IS2) 129 : 18 CONTINUE 130 : GOTO 1000 131 : 132 : C---- Les deux maillages entrés sont complexes 133 : 20 CONTINUE 134 : NBSOU1=IPT1.LISOUS(/1) 135 : NBSOU2=IPT2.LISOUS(/1) 136 : NBELEM=0 137 : NBNN=0 138 : NBREF=0 139 : NBSOUS=NBSOU1+NBSOU2 140 : SEGINI IPT4 141 : DO 21 I1=1,NBSOU1 142 : IPT4.LISOUS(I1)=IPT1.LISOUS(I1) 143 : 21 CONTINUE 144 : ISUP=0 145 : DO 22 I2=1,NBSOU2 146 : IPT5=IPT2.LISOUS(I2) 147 : SEGACT IPT5 148 : ITYP=IPT5.ITYPEL 149 : DO 23 I1=1,NBSOU1 150 : IPT6=IPT4.LISOUS(I1) 151 : IF (IPT6.EQ.0) GOTO 23 152 : SEGACT IPT6 153 : IF (IPT6.ITYPEL.NE.ITYP) GOTO 24 154 : IF (IPT6.NUM(/1).NE.IPT5.NUM(/1)) GOTO 24 155 : IF (IPT5.EQ.IPT6) GOTO 25 155 : CALL OUEXCL(IPT5,IPT6,IPT7) 156 : IF (IPT7.EQ.0) GOTO 25 157 : SEGDES IPT5,IPT6 158 : IPT4.LISOUS(I1)=IPT7 159 : IPT4.LISOUS(NBSOU1+I2)=0 160 : ISUP=ISUP+1 161 : GOTO 22 162 : 25 ISUP=ISUP+2 163 : IPT4.LISOUS(I1)=0 164 : IPT4.LISOUS(NBSOU1+I2)=0 165 : SEGDES IPT5,IPT6 166 : GOTO 22 167 : 24 SEGDES IPT6 168 : 23 CONTINUE 169 : IPT4.LISOUS(NBSOU1+I2)=IPT5 170 : SEGDES IPT5 171 : 22 CONTINUE 172 : IF (ISUP.EQ.0) GOTO 30 173 : NBS=NBSOUS 174 : NBSOUS=NBSOUS-ISUP 175 : 176 : C-------- Cas d'un maillage vide --------------------------------- 177 : 178 : IF (NBSOUS.EQ.0) THEN 179 : NBELEM=0 180 : NBNN=0 181 : NBREF=0 182 : NBSOUS=0 183 : SEGINI IPT3 184 : IPT3.ITYPEL = 1 185 : GOTO 1000 186 : ENDIF 187 : 188 : SEGINI IPT3 189 : JS=0 190 : DO 35 IS=1,NBSOUS 191 : 36 JS=JS+1 192 : IF (IPT4.LISOUS(JS).EQ.0) GOTO 36 193 : IPT3.LISOUS(IS)=IPT4.LISOUS(JS) 194 : 35 CONTINUE 195 : SEGSUP IPT4 196 : IF (NBSOUS.NE.1) GOTO 1000 197 : 198 : IPT4=IPT3.LISOUS(1) 199 : SEGSUP IPT3 200 : 30 IPT3=IPT4 201 : SEGACT IPT3 202 : 203 : c 204 : c Nettoyage du maillage dans le cas ou il contient des sous-parties vides 205 : c 206 : 1000 SEGDES IPT1,IPT2 207 : IF (IPT3.LISOUS(/1) .NE. 0) THEN 208 : c le maillage a plusieurs sous zones 209 : NBSOUS = IPT3.LISOUS(/1) 210 : DO 1010 I=1,IPT3.LISOUS(/1) 211 : MELEME = IPT3.LISOUS(I) 212 : SEGACT MELEME 213 : IF (NUM(/2) .EQ. 0) THEN 214 : c 215 : c la sous partie est vide on va la supprimer 216 : c et tasser le tableau LISOUS 217 : DO 1020 J=I+1,IPT3.LISOUS(/1) 218 : * print *, 'on tasse' 219 : IPT3.LISOUS(J-1)=IPT3.LISOUS(J) 220 : 1020 CONTINUE 221 : c 222 : NBSOUS = NBSOUS - 1 223 : ENDIF 224 : SEGDES MELEME 225 : 1010 CONTINUE 226 : IF (NBSOUS .NE. IPT3.LISOUS(/1)) THEN 227 : NBNN = 0 228 : NBELEM = 0 229 : NBREF = 0 230 : SEGADJ IPT3 231 : * print *, 'on ajuste' 232 : ENDIF 233 : IF ( NBSOUS .EQ. 1 ) IPT3 = IPT3.LISOUS(1) 234 : ENDIF 235 : c 236 : SEGDES IPT3 236 : CALL ECROBJ('MAILLAGE',IPT3) 237 : RETURN 238 : 239 : END 240 : 241 : 242 : 243 : 244 :
© Cast3M 2003 - All rights reserved.
Disclaimer