1 : C REDURI SOURCE CHAT 09/10/09 21:22:29 6519 2 : subroutine reduri(mrigid,moleme,irigre) 3 : implicit real*8(a-h,o-z) 4 : implicit integer (i-n) 5 : -INC SMRIGID 6 : -INC SMELEME 7 : -INC CCOPTIO 8 : -INC SMCOORD 9 : segment icpr(xcoor(/1)/(idim+1)) 10 : segment inode(ino) 11 : segment jelnum(imaxel,ino) 12 : segment izone(imaxel,ino) 13 : irigre=0 14 : ipt1=moleme 15 : segact ipt1 16 : meleme=ipt1 17 : nbso1=ipt1.lisous(/1) 18 : ino=0 19 : 20 : * 21 : * creation, d'une numerotation locale 22 : * 23 : segini icpr 24 : do 1 i =1, max(nbso1,1) 25 : if(nbso1.ne.0) then 26 : meleme=ipt1.lisous(i) 27 : segact meleme 28 : endif 29 : do 2 j=1,num(/2) 30 : do 2 k=1,num(/1) 31 : ia= num(k,j) 32 : if(icpr(ia).eq.0) then 33 : ino=ino+1 34 : icpr(ia)=ino 35 : endif 36 : 2 continue 37 : 1 continue 38 : * 39 : * on compte combien d'elements touche un noeud 40 : * 41 : segini inode 42 : do 3 i=1,max(nbso1,1) 43 : if(nbso1.ne.0) then 44 : meleme=ipt1.lisous(i) 45 : endif 46 : do 4 j=1,num(/2) 47 : do 4 k=1,num(/1) 48 : ia=num(k,j) 49 : ib= icpr(ia) 50 : inode(ib)=inode(ib)+1 51 : 4 continue 52 : 3 continue 53 : imaxel=0 54 : do i=1,ino 55 : imaxel=max(imaxel,inode(i)) 56 : inode(i)=0 57 : enddo 58 : segini jelnum,izone 59 : * 60 : * jelnum(i,k) dira le Ieme element qui touche le noeud k 61 : * izone (i,k) dira dans quel lisous le ieme element se trouve 62 : * attention le noeud K est le plus petit de l'élément 63 : do 5 i=1,max(nbso1,1) 64 : if(nbso1.ne.0) then 65 : meleme=ipt1.lisous(i) 66 : endif 67 : do 6 j=1,num(/2) 68 : ipeti=xcoor(/1) 69 : do k=1,num(/1) 70 : ipeti=min(num(k,j),ipeti) 71 : enddo 72 : ib= icpr(ipeti) 73 : inode(ib)=inode(ib)+1 74 : ic=inode(ib) 75 : jelnum(ic,ib)=j 76 : izone(ic,ib)=i 77 : 6 continue 78 : 5 continue 79 : * 80 : * travail sur les rigidites elementaires 81 : * 82 : segact mrigid 83 : nrigel=coerig(/1) 84 : nrige=irigel(/1) 85 : segini ri1 86 : irzon=0 87 : do 10 i=1,irigel(/2) 88 : ipt3=irigel(1,i) 89 : segact ipt3 90 : xmatri=irigel(4,i) 91 : ielzo=0 92 : do 11 j=1,ipt3.num(/2) 93 : ipeti=xcoor(/1) 94 : do k=1,ipt3.num(/1) 95 : ipeti=min(ipeti,ipt3.num(k,j)) 96 : enddo 97 : 98 : 99 : * on regarde s'il existe un element de ipt1 ayant ce noeud en plus 100 : * petitre position si non on passe a l'élément suivant 101 : ib=icpr(ipeti) 102 : if(ib.eq.0) go to 11 103 : if(inode(ib).eq.0) go to 11 104 : do 13 mm=1,inode(ib) 105 : if(nbso1.ne.0)then 106 : meleme= ipt1.lisous(izone(mm,ib)) 107 : endif 108 : if(ipt3.num(/1).ne.num(/1)) go to 13 109 : iel=jelnum(mm,ib) 110 : do in=1,ipt3.num(/1) 111 : if( ipt3.num(in,j).ne.num(in,iel))go to 13 112 : enddo 113 : * on a trouver un element a conserver 114 : if(ielzo.eq.0) then 115 : segini,ipt4=ipt3 116 : irzon=irzon+1 117 : do kk=1,irigel(/1) 118 : ri1.irigel(kk,irzon)=irigel(kk,i) 119 : enddo 120 : ri1.irigel(1,irzon)=ipt4 121 : ri1.coerig(irzon)=coerig(i) 122 : ri1.mtymat=mtymat 123 : xmatri=irigel(4,i) 124 : segact xmatri 125 : segini,xmatr1=xmatri 126 : ri1.irigel(4,irzon)= xmatr1 127 : endif 128 : ielzo=ielzo+1 129 : do io=1,re(/2) 130 : do iu=1,re(/1) 131 : xmatr1.re(iu,io,ielzo)=re(iu,io,j) 132 : enddo 133 : enddo 134 : * imatr1.imattt(ielzo)=imattt(j) 135 : do kk=1,ipt3.num(/1) 136 : ipt4.num(kk,ielzo)=ipt3.num(kk,j) 137 : enddo 138 : 13 continue 139 : 11 continue 140 : * on ajuste les longueur si besoin 141 : if(ielzo.ne.0) then 142 : if(ielzo.ne.ipt4.num(/2)) then 143 : nbsous=0 144 : nbelem= ielzo 145 : nbnn=ipt4.num(/1) 146 : nbref=0 147 : segadj ipt4 148 : nelrig=ielzo 149 : nligrp= xmatr1.re(/2) 150 : nligrd= xmatr1.re(/1) 151 : segadj xmatr1 152 : segdes ipt4,xmatr1 153 : else 154 : ri1.irigel(4,irzon)=xmatri 155 : ri1.irigel(1,irzon)=ipt3 156 : segsup xmatr1,ipt4 157 : endif 158 : endif 159 : segdes xmatri 160 : 10 continue 161 : if(irzon.eq.0) then 162 : segdes mrigid 162 : call erreur(21) 163 : elseif(irzon.ne.coerig(/1)) then 164 : nrigel=irzon 165 : nrige=irigel(/1) 166 : segadj ri1 167 : segdes ri1 168 : irigre=ri1 169 : else 170 : do io=1,irzon 171 : if( ri1.irigel(1,io).ne.irigel(1,io) )go to 20 172 : enddo 173 : irigre= mrigid 174 : go to 21 175 : 20 continue 176 : irigre=ri1 177 : 178 : 21 continue 179 : endif 180 : do iou=1,irigel(/2) 181 : ipt3=irigel(1,iou) 182 : segdes ipt3 183 : enddo 184 : segdes mrigid 185 : if(irigre.eq.mrigid) then 186 : segsup ri1 187 : else 188 : segdes ri1 189 : endif 190 : segsup izone,icpr,jelnum,inode 191 : return 192 : end 193 : 194 :
© Cast3M 2003 - All rights reserved.
Disclaimer