1 : C NUMOPT SOURCE FANDEUR 11/10/10 21:15:09 7166 2 : C RACINE DE LA NUMEROTATION POUR LA SORTIE SUR FAC 3 : C 4 : SUBROUTINE NUMOPT(MELEME,ICPR,NODES) 5 : IMPLICIT INTEGER(I-N) 6 : -INC SMELEME 7 : -INC SMCOORD 8 : -INC CCOPTIO 9 : -INC CCPRECO 10 : CHARACTER*4 MVAL 11 : DATA MVAL/'NOOP'/ 12 : SEGMENT MEMJT1(NKON) 13 : SEGMENT MEMJT2(NKON) 14 : SEGMENT IPOME(NODES+1) 15 : SEGMENT JNT(NODES) 16 : SEGMENT JMEM(NODES) 17 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 18 : SEGMENT ICPREN(XCOOR(/1)/(IDIM+1)) 19 : SEGMENT IDCP(XCOOR(/1)/(IDIM+1)) 20 : SEGMENT JOINT(NODES) 21 : SEGMENT NEWJT(NODES) 22 : icpren=0 23 : segact mcoord 24 : segact meleme 25 : * cas trivial ou le maillage est fait de points isoles 25 : CALL LIRMOT(MVAL,1,IRET,0) 26 : if (itypel.eq.1.or.iret.eq.1.or.nucrou.eq.-1) then 27 : segact icpr*MOD 28 : ia=0 29 : ipt1=meleme 30 : segact meleme 31 : do k=1,max(1,lisous(/1)) 32 : if (lisous(/1).ne.0) ipt1=lisous(k) 33 : segact ipt1 34 : do j= ipt1.num(/2),1,-1 35 : do i=1,ipt1.num(/1) 36 : if (icpr(ipt1.num(i,j)).eq.0) then 37 : ia=ia+1 38 : icpr(ipt1.num(i,j))=ia 39 : endif 40 : enddo 41 : enddo 42 : enddo 43 : nodes=ia 44 : return 45 : endif 46 : nucro=0 47 : * si plus de 2000 noeuds dans le meleme numérotation NS 48 : segact icpr*mod 49 : do i=1,icpr(/1) 50 : icpr(i)=0 51 : enddo 52 : segact meleme 53 : ia=0 54 : ib=0 55 : ipt1=meleme 56 : ifrot=0 57 : do 60 isous=1,max(1,lisous(/1)) 58 : if (lisous(/1).ne.0) ipt1=lisous(isous) 59 : segact ipt1 60 : if (ipt1.itypel.eq.-22) then 61 : * write (6,*) ' frottement ' 62 : ifrot=1 63 : endif 64 : ib=max(ib,ipt1.num(/1)) 65 : do 50 i=1,ipt1.num(/2) 66 : do 50 j=1,ipt1.num(/1) 67 : if (icpr(ipt1.num(j,i)).eq.0) then 68 : ia=ia+1 69 : icpr(ipt1.num(j,i))=ia 70 : endif 71 : 50 continue 72 : 60 continue 73 : if (ia.lt.ib*5 ) then 74 : * write (6,*) ' superelement detecte ',ia,ib 75 : ia=1 76 : endif 77 : do i=1,icpr(/1) 78 : icpr(i)=0 79 : enddo 80 : if (ia.gt.2000) then 81 : nucro=2 82 : izrosf=16 83 : endif 84 : if (ia.le.2000) nucro=0 85 : IF(NUCROU.EQ.1) nucro=0 86 : IF(NUCROU.EQ.2) nucro=2 87 : * en cas de frottement forcément nested dissection pour placer correctement les mult de frot 88 : if (ifrot.eq.1) nucro=2 88 : CALL LIRMOT(MVAL,1,IRET,0) 89 : if (iret.eq.0) then 90 : * a t'on deja fait l'operation ??? 91 : segini icpren,idcp 92 : incren=0 93 : do isous=2,lisous(/1) 94 : ipt3=lisous(isous) 95 : segact ipt3 96 : * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans 97 : * l'ordre "usuel" 98 : do j=1,ipt3.num(/2) 99 : do i=1,ipt3.num(/1) 100 : ip=ipt3.num(i,j) 101 : if (icpren(ip).eq.0) then 102 : incren=incren+1 103 : icpren(ip)=incren 104 : endif 105 : enddo 106 : enddo 107 : enddo 108 : do i=1,icpren(/1) 109 : if (icpren(i).ne.0) idcp(icpren(i))=i 110 : enddo 111 : 112 : do 150 ip=1,30 113 : if (prenum(ip).ne.0) then 114 : ipt1=prenum(ip) 115 : segact ipt1 116 : * write (6,*) ' prenum ',ip,lisous(/1),ipt1.lisous(/1) 117 : if (lisous(/1)+1.eq.ipt1.lisous(/1)) then 118 : *SG Attention ! On a osé stocker le type de renumérotation qui avait été 119 : *SG calculée dans le itypel 120 : ipt2=ipt1.lisous(ipt1.lisous(/1)) 121 : segact ipt2 122 : nucroa=ipt2.itypel 123 : segdes ipt2 124 : if (nucro.ne.nucroa) goto 11 125 : * verif maillage identique 126 : * write (6,*) ' maillage 1 ',lisous(/1) 127 : * write (6,*) ' maillage 2 ',ipt1.lisous(/1) 128 : do isous=2,lisous(/1) 129 : ipt3=lisous(isous) 130 : ipt4=ipt1.lisous(isous) 131 : segact ipt3,ipt4 132 : * write (6,*) ipt3.num(/1),ipt4.num(/1),ipt3.num(/2),ipt4.num(/2) 133 : * write (6,*) ' itypel ',ipt3.itypel,ipt4.itypel 134 : if (ipt3.itypel.ne.ipt4.itypel) goto 10 135 : if (ipt3.num(/1).ne.ipt4.num(/1)) goto 10 136 : if (ipt3.num(/2).ne.ipt4.num(/2)) goto 10 137 : * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans 138 : * l'ordre "usuel" 139 : do j=1,ipt3.num(/2) 140 : do i=1,ipt3.num(/1) 141 : * write (6,*) i,j,ipt3.num(i,j), 142 : * > icpren(ipt3.num(i,j)),ipt4.num(i,j) 143 : if (icpren(ipt3.num(i,j)).ne.ipt4.num(i,j)) goto 10 144 : enddo 145 : enddo 146 : segdes ipt3,ipt4 147 : enddo 148 : if (iimpi.ne.0) write (6,*) 149 : > ' preconditionnement de la numerotation ',ip, 150 : > (prenum(i),i=1,30) 151 : ipt2=ipt1.lisous(ipt1.lisous(/1)) 152 : segact ipt2 153 : segact icpr*MOD 154 : nodes=ipt2.num(/2) 155 : * write (6,*) ' icpr(/1),nodes ',icpr(/1),nodes 156 : do i=1,nodes 157 : if (idcp(ipt2.num(1,i)).ne.0) icpr(idcp(ipt2.num(1,i)))=i 158 : enddo 159 : ia=nodes 160 : segdes ipt1,ipt2 161 : * write (6,*) ' apres precond dans numopt ' 162 : * write (6,*) (icpr(i),i=1,icpr(/1)) 163 : return 164 : 165 : 10 continue 166 : segdes ipt3,ipt4 167 : 11 continue 168 : endif 169 : endif 170 : 150 continue 171 : if (nucro.eq.1) then 171 : call numop1(MELEME,ICPR,NODES) 172 : goto 300 173 : endif 174 : if (nucro.eq.2) then 174 : call numop2(MELEME,ICPR,NODES) 175 : segact icpr*mod 176 : goto 300 177 : endif 178 : endif 178 : if (iret.eq.1) call refus 179 : IENORM=2000000000 180 : NODES=XCOOR(/1)/(IDIM+1) 181 : SEGACT ICPR*MOD 182 : SEGACT MELEME 183 : DO 200 I=1,ICPR(/1) 184 : 200 ICPR(I)=0 185 : IPT1=MELEME 186 : IKOU=0 187 : DO 202 IO=1,MAX(1,LISOUS(/1)) 188 : IF (LISOUS(/1).NE.0) THEN 189 : IPT1=LISOUS(IO) 190 : SEGACT IPT1 191 : ENDIF 192 : DO 203 I=1,IPT1.NUM(/1) 193 : DO 203 J=1,IPT1.NUM(/2) 194 : IJ=IPT1.NUM(I,J) 195 : IF (ICPR(IJ).NE.0) GOTO 203 196 : IKOU=IKOU+1 197 : ICPR(IJ)=IKOU 198 : 203 CONTINUE 199 : 202 CONTINUE 200 : NODES=IKOU 201 : SEGINI JNT,JMEM,NEWJT,JOINT,IPOME 202 : DO 1 I=1,NODES 203 : 1 JMEM(I)=0 204 : IPT1=MELEME 205 : DO 3 IO=1,MAX(1,LISOUS(/1)) 206 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 207 : DO 4 I=1,IPT1.NUM(/1) 208 : DO 4 J=1,IPT1.NUM(/2) 209 : JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1 210 : 4 CONTINUE 211 : 3 CONTINUE 212 : IPOME(1)=0 213 : DO 6 I=1,NODES 214 : IPOME(I+1)=IPOME (I) + JMEM(I) 215 : 6 CONTINUE 216 : NKON=IPOME(NODES+1) 217 : SEGINI MEMJT1,memjt2 218 : DO 90 J=1,NODES 219 : 90 JMEM(J)=0 220 : IPT1=MELEME 221 : DO 101 IO=1,MAX(1,LISOUS(/1)) 222 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 223 : DO 100 I=1,IPT1.NUM(/2) 224 : DO 100 J=1,IPT1.NUM(/1) 225 : IND=ICPR(IPT1.NUM(J,I)) 226 : JMEM(IND)=JMEM(IND)+1 227 : MEMJT1(IPOME(IND)+JMEM(IND))=I 228 : MEMJT2(IPOME(IND)+JMEM(IND))=IO 229 : 100 CONTINUE 230 : 101 CONTINUE 231 : IDIFF=1 231 : CALL OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,IDIFF,IPOME, 232 : # ICPR,NODES,NOOPTI) 233 : DO 110 I=1,NODES 234 : JNT(I)=NODES-JNT(I)+1 235 : 110 CONTINUE 236 : C PERMUTER LES COORDONNEES ET CORRIGER IPAD 237 : DO 111 I=1,icpr(/1) 238 : IF (ICPR(I).EQ.0) GOTO 111 239 : ICPR(I)=JNT(ICPR(I)) 240 : 111 CONTINUE 241 : IF(NOOPTI .EQ.0) GO TO 116 242 : IA=0 243 : DO 115 I=1,icpr(/1) 244 : IF(ICPR(I).EQ.0) GO TO 115 245 : IA=IA+1 246 : ICPR(I)=IA 247 : 115 CONTINUE 248 : 116 CONTINUE 249 : SEGSUP MEMJT1,MEMJT2,JMEM,NEWJT,JOINT,IPOME 250 : SEGSUP JNT 251 : * Mise en commentaire du retuen par SG car comme cela on préconditionne 252 : * aussi le Cuthill-McKee 253 : * RETURN 254 : 300 continue 255 : * sauver le resultat au cas ou on veuille recommencer 256 : segini,ipt1=meleme 257 : nbsous=ipt1.lisous(/1)+1 258 : nbref=ipt1.lisref(/1) 259 : nbnn=ipt1.num(/1) 260 : nbelem=ipt1.num(/2) 261 : segadj ipt1 262 : nbnn=1 263 : nbsous=0 264 : nbref=0 265 : nbelem=nodes 266 : segini ipt2 267 : *SG Attention ! On ose stocker le type de renumérotation qui a été 268 : *SG calculée dans le itypel 269 : ipt2.itypel=nucro 270 : ia=0 271 : do 120 i=1,icpr(/1) 272 : if (icpr(i).gt.nodes.or.icpr(i).eq.0) goto 120 273 : ia=ia+1 274 : ipt2.num(1,icpr(i))=icpren(i) 275 : 120 continue 275 : * call ecmail(ipt2) 276 : ipt1.lisous(ipt1.lisous(/1))=ipt2 277 : segdes ipt2 278 : do 125 is=1,ipt1.lisous(/1)-1 279 : ipt2=ipt1.lisous(is) 280 : segini,ipt3=ipt2 281 : segdes ipt2 282 : * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans 283 : * l'ordre "usuel" 284 : do il=1,ipt3.num(/2) 285 : do ip=1,ipt3.num(/1) 286 : ipt3.num(ip,il)=icpren(ipt3.num(ip,il)) 287 : enddo 288 : enddo 289 : segdes ipt3 290 : ipt1.lisous(is)=ipt3 291 : 125 continue 292 : if (ipt1.lisous(/1).eq.1) goto 131 293 : segdes ipt1 294 : do 130 ip=29,1,-1 295 : prenum(ip+1)=prenum(ip) 296 : 130 continue 297 : prenum(1)=ipt1 298 : 131 continue 299 : if (icpren.ne.0) segsup icpren,idcp 300 : segact icpr*mod 301 : * write (6,*) ' fin de numopt ' 302 : * write (6,*) (icpr(i),i=1,icpr(/1)) 303 : * 304 : RETURN 305 : END 306 : 307 : 308 : 309 : 310 : 311 : 312 : 313 : 314 : 315 : 316 : 317 :
© Cast3M 2003 - All rights reserved.
Disclaimer