1 : C REDUMO SOURCE CHAT 11/03/16 21:30:34 6902 2 : 3 : SUBROUTINE REDUMO (IPMODL,IMEL, IRET) 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : *______________________________________________________________________ 8 : * 9 : * REDU D'UN MODELE SUR MELEME (APPELE PAR REDU) 10 : * 11 : * ENTREES : 12 : * --------- 13 : * IPMODL MODELE A REDUIRE (TYPE MMODEL) 14 : * IMEL MAILLAGE SUR LEQUEL ON DOIT REDUIRE (TYPE MELEME) 15 : * 16 : * SORTIE : 17 : * -------- 18 : * IRET MODELE REDUIT 19 : * = 0 SI PB 20 : * 21 : * REMARQUE : ON SE LIMITE A NE POUVOIR REDUIRE UN MODELE QUE SUR 22 : * ---------- UN MAILLAGE POUR LEQUEL TOUS SES ELEMENTS "ADHERENT" 23 : * AU MODELE ET DE PLUS IL FAUT QU'A CHAQUE SOUS ZONE 24 : * DU MAILLAGE IMEL CORRESPONDE UNE SOUS ZONE DANS LE 25 : * MODELE (IE UNE SOUS ZONE DU MAILLAGE IMEL NE PEUT 26 : * ETRE "A CHEVAL" SUR PLUSIEURS SOUS ZONES DU MODELE) 27 : * 28 : * limitation levee par degay 29 : * si le maillage est a cheval sur plusieurs sous zones 30 : * on le tronconne en autant de morceaux 31 : * 32 : * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 11 90 33 : * 34 : *______________________________________________________________________ 35 : * 36 : -INC CCOPTIO 37 : * 38 : -INC SMCOORD 39 : -INC SMELEME 40 : -INC SMMODEL 41 : * 42 : SEGMENT ICPR(NPT) 43 : SEGMENT ICOM(NBEL) 44 : SEGMENT ITRA1 45 : INTEGER ICC (IA+1) 46 : ENDSEGMENT 47 : segment itra2 48 : INTEGER IRE(ima) 49 : ENDSEGMENT 50 : LOGICAL INIT,DEJA 51 : * 52 : IRET=0 53 : * 54 : DEJA = .FALSE. 55 : * 56 : MMODEL = IPMODL 57 : SEGACT MMODEL 58 : SEGINI,MMODE1=MMODEL 59 : NSOUS=KMODEL(/1) 60 : * 61 : * FABRICATION DE ICPR QUI DIRA SI UN POINT DU MODELE EST TOUCHE PAR 62 : * LE MAILLAGE IMEL ET SUR COMBIEN D'ELEMENTS ON VA TRAVAILLER PAR TYPE 63 : * D'ELEMENTS 64 : * 65 : NPT = XCOOR(/1)/(IDIM+1) 66 : ICPR = 0 67 : * 68 : * on duplique le maillage pour pouvoir le modifier si besoin est 69 : IPT1 = IMEL 70 : SEGACT,IPT1 71 : NBSOU1=IPT1.LISOUS(/1) 72 : MELEME = IPT1 73 : * 74 : * BOUCLE CONDITIONNNELLE SUR LES SOUS ZONES DU MAILLAGE IMEL 75 : * 76 : IBOU1 = 0 77 : NS01 = 0 78 : * 79 : 1 CONTINUE 80 : IBOU1 = IBOU1 + 1 81 : IF(NBSOU1.NE.0) THEN 82 : MELEME = IPT1.LISOUS(IBOU1) 83 : ENDIF 84 : SEGACT MELEME 85 : * 86 : * NNNT :NB D'ELEMENTS DE IMEL POUR LA SOUS ZONE CONSIDEREE 87 : NNNT=NUM(/2) 88 : * 89 : * Creation ou remise a zero du segment ICPR 90 : IF (ICPR.EQ.0) THEN 91 : SEGINI,ICPR 92 : ELSE 93 : DO i = 1, NPT 94 : ICPR(i) = 0 95 : ENDDO 96 : ENDIF 97 : * 98 : * CREATION D'UNE NUMEROTATION LOCALE 99 : * 100 : IA=0 101 : DO 3 J=1,NNNT 102 : DO 3 K=1,NUM(/1) 103 : ID=NUM(K,J) 104 : IF(ICPR(ID).NE.0) GO TO 3 105 : IA=IA+1 106 : ICPR(ID)=IA 107 : 3 CONTINUE 108 : * 109 : * FABRICATION DE ITRA1 puis 2 : 110 : * ICC DONNE LE NOMBRE D'ELEMENTS touchant le i eme noeud local 111 : * 112 : SEGINI ITRA1 113 : DO 8 J=1,NNNT 114 : DO 8 K=1,NUM(/1) 115 : ID=ICPR(NUM(K,J)) 116 : ICC(ID)=ICC(ID)+1 117 : 8 CONTINUE 118 : * 119 : * fabrication de ire stocker les elements touchant le noeud i 120 : * 121 : igt=icc(1) 122 : DO 80 j=2,ia 123 : if( igt.lt.icc(j) ) igt = icc(j) 124 : icc(j)=icc(j)+icc(j-1) 125 : 80 CONTINUE 126 : ima = icc(ia) 127 : icc(ia+1) = ima 128 : * write(6,*) 'taille de ire ', ima, ia,igt 129 : segini itra2 130 : do 81 j=1,NNNT 131 : DO 81 k=1,num(/1) 132 : id=icpr(num(k,j)) 133 : ie = icc(id) 134 : icc(id)=icc(id)-1 135 : ire(ie)= j 136 : 81 CONTINUE 137 : * 138 : * IL FAUT MAINTENANT REGARDER SI DANS UNE SOUS ZONE IMODEL IL 139 : * EXISTE LES ELEMENTS DE LA SOUS ZONE DU MELEME IMEL 140 : * BOUCLE SUR LES SOUS ZONES DU MODELE 141 : * 142 : IFLAG=0 143 : IMOD1=0 144 : DO 10 I=1,KMODEL(/1) 145 : SEGACT MELEME 146 : * write(6,*) ' boucle 10 ibou1 i', ibou1, i 147 : IMODEL=KMODEL(I) 148 : SEGACT IMODEL 149 : IPT2=IMAMOD 150 : SEGACT IPT2 151 : * 152 : IF(ITYPEL.NE.IPT2.ITYPEL) GO TO 11 153 : * 154 : INIT=.FALSE. 155 : 156 : NBEL = NUM(/2) 157 : SEGINI ICOM 158 : * 159 : ICO=0 160 : NBEL2=IPT2.NUM(/1) 161 : DO 12 K=1,IPT2.NUM(/2) 162 : DO 13 L=1,NBEL2 163 : ID=IPT2.NUM(L,K) 164 : IDD = ICPR(ID) 165 : IF(IDD.EQ.0) GO TO 12 166 : 13 CONTINUE 167 : * 168 : ID =IPT2.NUM(1,K) 169 : IDD=ICPR(ID) 170 : IDE=ICC(IDD)+1 171 : * 172 : * OK L'ELEMENT K POSSEDE SES NOEUDS DANS IMEL 173 : * 174 : IF(ITYPEL.EQ.1) THEN 175 : IRE1=IRE(ide) 176 : GOTO 20 177 : ENDIF 178 : * 179 : * CES NOEUDS CORRESPONDENT-T-ILS A UN MEME ELEMENT IRE1 180 : * 181 : IDF=ICC(IDD+1) 182 : DO 14 L=IDE,IDF 183 : IRE1=IRE(L) 184 : DO 15 M=2,NBEL2 185 : IDD2=ICPR(IPT2.NUM(M,K)) 186 : IF(IDD2.EQ.0) GO TO 12 187 : IDE2=ICC(IDD2)+1 188 : IDF2=ICC(IDD2+1) 189 : DO 16 N=IDE2,IDF2 190 : IF(IRE(N).EQ.IRE1) GO TO 15 191 : 16 CONTINUE 192 : GO TO 14 193 : 15 CONTINUE 194 : * 195 : * ON A TROUVE UN ELEMENT COMMUN AUX 2 MAILLAGES 196 : * 197 : GOTO 20 198 : 14 CONTINUE 199 : * 200 : GOTO 12 201 : * 202 : 20 CONTINUE 203 : IF (.NOT.INIT) INIT=.TRUE. 204 : IFLAG=1 205 : ICOM(IRE1)=1 206 : ICO=ICO+1 207 : 12 CONTINUE 208 : * 209 : IF (INIT) THEN 210 : * 211 : * LE NB D'ELEMENTS EST-IL EGAL POUR LA SOUS ZONE IMEL ET 212 : * LA SOUS ZONE DU MODELE 213 : * 214 : * print *, 'element en commun' ,'ico=',ico,'nnnt=',nnnt 215 : IF (ICO.EQ.NNNT) THEN 216 : NS01=NS01+1 217 : IMOD1=IMOD1+1 218 : SEGINI,IMODE1=IMODEL 219 : C Dans le cas DARCY on ignore la table de préconditionnement afin de 220 : C pouvoir la recalculer correctement par la suite 221 : NFOR=IMODE1.FORMOD(/2) 221 : CALL PLACE (IMODE1.FORMOD,NFOR,IDARC,'DARCY') 221 : CALL PLACE (IMODE1.FORMOD,NFOR,IEULE,'EULER') 221 : CALL PLACE (IMODE1.FORMOD,NFOR,INAVI,'NAVIER_STOKES') 222 : IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) 223 : & IMODE1.INFMOD(2)=0 224 : MMODE1.KMODEL(NS01)=IMODE1 225 : IMODE1.IMAMOD=MELEME 226 : C* Cas particulier : Elements type XFEM 227 : IF (NUMMFR(IMODE1.NEFMOD).EQ.63) 227 : & CALL PARTXR(IMODEL,0,IMODE1) 228 : * write(6,*) ' meleme imamod ' , meleme 229 : * 230 : SEGDES IMODE1 231 : ELSE 232 : * 233 : * IL FAUT SCINDER LE SOUS MAILAGE EN DEUX 234 : * 235 : * creation des deux maillages dont l'union est le maillage meleme 236 : NBNN = NUM(/1) 237 : NBELEM = ICO 238 : NBREF = 0 239 : NBSOUS = 0 240 : SEGINI IPT3 241 : NBELEM = NUM(/2) - ICO 242 : SEGINI IPT4 243 : IPT3.ITYPEL = ITYPEL 244 : IPT4.ITYPEL = ITYPEL 245 : I3 = 0 246 : I4 = 0 247 : DO 25 II=1,NUM(/2) 248 : IF (ICOM(II) .EQ. 1) THEN 249 : * l'element est commun aux deux maillages 250 : I3=I3+1 251 : IPT3.ICOLOR(I3)=ICOLOR(II) 252 : DO 23 JJ=1,NUM(/1) 253 : IPT3.NUM(JJ,I3)=NUM(JJ,II) 254 : 23 CONTINUE 255 : ELSE 256 : * l'element appartient seulement a meleme 257 : I4=I4+1 258 : IPT4.ICOLOR(I4)=ICOLOR(II) 259 : DO 24 JJ=1,NUM(/1) 260 : IPT4.NUM(JJ,I4)=NUM(JJ,II) 261 : 24 CONTINUE 262 : ENDIF 263 : 25 CONTINUE 264 : * 265 : * modification de ipt1 266 : * 267 : NBREF=0 268 : NBELEM=0 269 : NBNN=0 270 : IF (IPT1.LISOUS(/1) .EQ. 0) THEN 271 : NBSOUS=2 272 : SEGINI IPT5 273 : IPT5.LISOUS(1)=IPT3 274 : IPT5.LISOUS(2)=IPT4 275 : SEGDES IPT1 276 : IPT1=IPT5 277 : ELSE 278 : IF (.NOT. DEJA) THEN 279 : SEGINI,IPT5=IPT1 280 : SEGDES IPT1 281 : IPT1 = IPT5 282 : ENDIF 283 : NBSOUS=IPT1.LISOUS(/1)+1 284 : SEGADJ IPT1 285 : IPT1.LISOUS(IBOU1)=IPT3 286 : IPT1.LISOUS(NBSOUS)=IPT4 287 : SEGDES MELEME 288 : ENDIF 289 : IBOU1=IBOU1-1 290 : NBSOU1=NBSOUS 291 : NS01=NS01-IMOD1 292 : SEGDES IMODEL 293 : SEGSUP ICOM,ITRA1,ITRA2 294 : GOTO 1 295 : * 296 : ENDIF 297 : ENDIF 298 : SEGSUP ICOM 299 : 11 CONTINUE 300 : SEGDES IMODEL 301 : 10 CONTINUE 302 : * 303 : SEGSUP,ITRA1,ITRA2 304 : SEGDES,MELEME,IPT2 305 : 306 : IF (IFLAG.EQ.0) THEN 307 : * 308 : * ON N'A PAS TROUVE DE SOUS ZONE DANS LE MODELE QUI COR- 309 : * RESPONDENT A UNE SOUS ZONE DE IMEL 310 : * 311 : MOTERR(1:8)='MAILLAGE' 312 : MOTERR(9:16)='MODELE' 312 : CALL ERREUR(135) 313 : SEGDES,IPT1 314 : SEGSUP MMODE1 315 : GOTO 901 316 : ENDIF 317 : * 318 : * FIN DE LA BOUCLE SUR LES SOUS ZONES DU MAILLAGE 319 : * 320 : * print *, 'nbsou1=' , 'ibou1=' ,ibou1 321 : IF (IBOU1 .LT. NBSOU1 ) GOTO 1 322 : * 323 : SEGDES IPT1 324 : IF(NS01.NE.NSOUS) THEN 325 : N1=NS01 326 : SEGADJ,MMODE1 327 : ENDIF 328 : IRET=MMODE1 329 : 330 : 900 CONTINUE 331 : SEGDES,MMODE1 332 : 901 CONTINUE 333 : SEGDES,MMODEL 334 : C- Un peu de menage 335 : IF (ICPR.GT.0) SEGSUP,ICPR 336 : 337 : RETURN 338 : END 339 : 340 : 341 :
© Cast3M 2003 - All rights reserved.
Disclaimer