1 : C RENUEL SOURCE PV 09/11/16 21:15:17 6538 2 : subroutine renuel(ipt6) 3 : * 4 : * renumerote les elements dans un meleme de proche en proche 5 : * ne fonctionne que pour un meleme simple 6 : * 7 : -INC CCOPTIO 8 : -INC SMELEME 9 : -INC SMCOORD 10 : SEGMENT IADJ(NODES+1) 11 : SEGMENT JADJC(JADDIM) 12 : C IADJ(i) pointe sur JADJC qui contient les voisins de i entre 13 : C IADJ(i) et IADJ(i+1)-1 14 : SEGMENT IELFAI(NBELEM) 15 : SEGMENT IPTFAI(NODES) 16 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 17 : SEGMENT IPLIST(NODES) 18 : * 19 : segact mcoord 20 : segini icpr 21 : segact ipt6*mod 22 : meleme=ipt6 23 : do 10000 isous=1,max(1,ipt6.lisous(/1)) 24 : if (ipt6.lisous(/1).ne.0) meleme=ipt6.lisous(isous) 25 : segact meleme*mod 26 : segini,ipt1=meleme 27 : ipt2=meleme 28 : nodes=0 29 : do 100 il=1,ipt1.num(/2) 30 : do 100 ip=1,ipt1.num(/1) 31 : if (icpr(num(ip,il)).ne.0) goto 100 32 : nodes=nodes+1 33 : icpr(num(ip,il))=nodes 34 : 100 continue 35 : ** iadj: nombre d'elements touchant un noeud 36 : segini iadj 37 : do 200 il=1,ipt1.num(/2) 38 : do 200 ip=1,ipt1.num(/1) 39 : ipt=icpr(num(ip,il)) 40 : iadj(ipt)=iadj(ipt)+1 41 : 200 continue 42 : ** position fin dans jadjc 43 : do ipt=1,nodes 44 : iadj(ipt+1)=iadj(ipt)+iadj(ipt+1) 45 : enddo 46 : ** iadjc: element touchant noeud 47 : JADDIM=iadj(nodes+1) 48 : segini jadjc 49 : do 300 il=1,ipt1.num(/2) 50 : do 300 ip=1,ipt1.num(/1) 51 : ipt=icpr(num(ip,il)) 52 : jadjc(iadj(ipt))=il 53 : iadj(ipt)=iadj(ipt)-1 54 : 300 continue 55 : * creation tableau des elements faits, tableau des noeuds faits, et 56 : * et nouveau meleme 57 : nbsous=0 58 : nbref=0 59 : nbnn=ipt1.num(/1) 60 : nbelem=ipt1.num(/2) 61 : segini ielfai,iptfai 62 : ipt2.itypel=ipt1.itypel 63 : * remplissage maillage ordonnee et noeuds ordonné 64 : ielcou=0 65 : segini iplist 66 : * point de depart chosi par minimum degre 67 : nbconn=100000 68 : idep=0 69 : do ip=1,nodes 70 : nbc=iadj(ip+1)-iadj(ip) 71 : if (nbc.lt.nbconn) then 72 : nbconn=nbc 73 : idep=ip 74 : endif 75 : enddo 75 : if (idep.eq.0) call erreur(5) 76 : iplist(1)=idep 77 : iptfai(idep)=1 78 : ipc=1 79 : ipf=1 80 : 1000 continue 81 : if (ipc.gt.nodes) goto 2000 82 : i=iplist(ipc) 83 : ipre=iadj(i)+1 84 : ider=iadj(i+1) 85 : do 1010 jel=ipre,ider 86 : iel=jadjc(jel) 87 : if (ielfai(iel).eq.1) goto 1010 88 : ielcou=ielcou+1 89 : do ip=1,nbnn 90 : ipt2.num(ip,ielcou)=ipt1.num(ip,iel) 91 : ipt=icpr(ipt1.num(ip,iel)) 92 : if (iptfai(ipt).eq.0) then 93 : ipf=ipf+1 94 : iplist(ipf)=ipt 95 : iptfai(ipt)=1 96 : endif 97 : enddo 98 : ielfai(iel)=1 99 : 1010 continue 100 : ipc=ipc+1 101 : if (ipc.le.ipf) goto 1000 102 : if (ipc.gt.nodes) goto 2000 103 : * plusieurs composantes connexes on cherche un nouveau point de depart 104 : nbconn=100000 105 : idep=0 106 : do ip=1,nodes 107 : if (iptfai(ip).eq.0) then 108 : nbc=iadj(ip+1)-iadj(ip) 109 : if (nbc.lt.nbconn) then 110 : nbconn=nbc 111 : idep=ip 112 : endif 113 : endif 114 : enddo 114 : if (idep.eq.0) call erreur(5) 115 : ipf=ipf+1 116 : iptfai(idep)=1 117 : iplist(ipf)=idep 118 : goto 1000 119 : * on a fini 120 : 2000 continue 121 : if (ipf.ne.nodes) write (6,*) ' probleme ',ipc,ipf,nodes 122 : segsup iadj,jadjc,ielfai,iptfai,icpr,iplist 123 : segdes ipt1,ipt2 124 : 10000 continue 125 : return 126 : end 127 :
© Cast3M 2003 - All rights reserved.
Disclaimer