1 : C MUCPRI SOURCE PV 13/04/16 21:15:21 7765 2 : subroutine mucpri(mchpo1,mrigid,mchpoi) 3 : C 4 : C **** multiplication d'une matrice(mrigid) par un champoin (mchpo1) 5 : C **** le resultat est un champoin (mchpoi). 6 : C **** iret=ire2*ire1 7 : C **** le champpoint resultat a la meme dimension que la matrice. 8 : C 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : -INC CCOPTIO 12 : -INC SMELEME 13 : -INC SMCHPOI 14 : -INC SMRIGID 15 : -INC SMCOORD 16 : segment itrav1 17 : * liste des inconnues duales dans le champ etendu 18 : character*4 nocod(nctod) 19 : integer ifod(nctod) 20 : endsegment 21 : segment itrav2 22 : * position des comps du chpo cree dans le nocod, nb pts par paquet du chpo 23 : integer liscomp(nctod,nsoupo),nbp(nsoupo) 24 : endsegment 25 : segment itrav4 26 : * champ dual etendu 27 : real*8 ivald(nctod,nbpts) 28 : endsegment 29 : character*4 charm 30 : * 31 : * constitution de la liste des composantes duales 32 : * 33 : nbpts=xcoor(/1)/(idim+1) 34 : segact mrigid 35 : nrigel=irigel(/2) 36 : if (imgeo2.ne.0) goto 1000 37 : * creation d'un champoin prototype 38 : * attention les mpoval ne sont pas crees 39 : segact mrigid*mod 40 : nctod=0 41 : do 27 irige=1,nrigel 42 : descr=irigel(3,irige) 43 : segact descr 44 : nctod=nctod+lisdua(/2) 45 : 27 continue 46 : segini itrav1 47 : nctod=0 48 : do 30 irige=1,nrigel 49 : descr=irigel(3,irige) 50 : do 32 i=1,lisdua(/2) 51 : do 33 j=1,nctod 52 : if (ifod(j).ne.irigel(5,irige)) goto 33 53 : if (nocod(j).eq.lisdua(i)) goto 31 54 : 33 continue 55 : nctod=nctod+1 56 : nocod(nctod)=lisdua(i) 57 : ifod(nctod)=irigel(5,irige) 58 : 31 continue 59 : 32 continue 60 : 30 continue 61 : * 62 : * expansion du chpo dual de la rigidite 63 : * 64 : segini itrav4 65 : do 40 irige=1,nrigel 66 : write(charm,fmt='(a4)') irigel(5,irige) 67 : descr=irigel(3,irige) 68 : ipt2=irigel(1,irige) 69 : segact ipt2 70 : do 45 ic=1,lisdua(/2) 71 : do 47 ir=1,nctod 72 : if (ifod(ir).ne.irigel(5,irige)) goto 47 73 : if (nocod(ir).eq.lisdua(ic)) goto 50 74 : 47 continue 75 : goto 45 76 : 50 continue 77 : if (charm.eq.'NOHA') then 78 : ivava=2**17+2**16 79 : else 80 : ivava=2**17+ifod(ir) 81 : endif 82 : do 55 iel=1,ipt2.num(/2) 83 : ivald(ir,ipt2.num(noeled(ic),iel))=ivava 84 : 55 continue 85 : 45 continue 86 : 40 continue 87 : * 88 : * creation du champoin resultant (sans les valeurs) 89 : * 90 : nat=1 91 : nsoupo=0 92 : segini mchpoi,itrav2 93 : segact mchpo1 94 : * jattri(1) = (mchpo1.jattri(1) * 4 )/ 2 95 : * par defaut les chpts issus d'un produit seront discret! PV 96 : jattri(1) = 2 97 : mochde='créé par mucpri' 98 : mtypoi=' ' 99 : ifopoi=mchpo1.ifopoi 100 : * on sauve de suite dans la raideur le prototype 101 : imgeo2=mchpoi 102 : * 103 : do 100 i=1,nbpts 104 : do 110 ir=1,nctod 105 : if (ivald(ir,i).ne.0) goto 120 106 : 110 continue 107 : goto 100 108 : 120 continue 109 : * point a garder test liste des composantes 110 : do 130 isoupo=ipchp(/1),1,-1 111 : msoupo=ipchp(isoupo) 112 : * regarder si meme composantes et harmonique que isoupo 113 : do 140 ic=1,nocomp(/2) 114 : if (ivald(liscomp(ic,isoupo),i).ne.2**17+noharm(ic)) goto 130 115 : 140 continue 116 : * verifier pas d'autres composantes 117 : indtot=0 118 : do 145 ir=1,nctod 119 : if (ivald(ir,i).ne.0) indtot=indtot+1 120 : 145 continue 121 : if (indtot.ne.nocomp(/2)) goto 130 122 : * ok on ajoute le pt dans sa liste 123 : nbp(isoupo)=nbp(isoupo)+1 124 : meleme=igeoc 125 : num(1,nbp(isoupo))=i 126 : goto 100 127 : 130 continue 128 : * creation d'un nouveau paquet 129 : 150 continue 130 : nsoupo=nsoupo+1 131 : segadj mchpoi,itrav2 132 : nc=0 133 : do 160 ir=1,nctod 134 : if (ivald(ir,i).eq.0) goto 160 135 : nc=nc+1 136 : liscomp(nc,nsoupo)=ir 137 : 160 continue 138 : segini msoupo 139 : ipchp(nsoupo)=msoupo 140 : do 165 ic=1,nc 141 : nocomp(ic)=nocod(liscomp(ic,nsoupo)) 142 : noharm(ic)=ifod(liscomp(ic,nsoupo)) 143 : 165 continue 144 : nbelem=nbpts 145 : nbnn=1 146 : nbsous=0 147 : nbref=0 148 : segini meleme 149 : itypel=1 150 : igeoc=meleme 151 : num(1,1)=i 152 : nbp(nsoupo)=1 153 : goto 100 154 : 100 continue 155 : do 170 isoup=1,nsoupo 156 : msoupo=ipchp(isoup) 157 : meleme=igeoc 158 : nbelem=nbp(isoup) 159 : nbnn=1 160 : nbsous=0 161 : nbref=0 162 : segadj meleme 163 : * si possible ne pas creer de nouveau meleme 163 : call crech1(meleme,1) 164 : igeoc=meleme 165 : 170 continue 166 : segsup itrav1,itrav2,itrav4 167 : 1000 continue 167 : call mucpr1(mchpo1,mrigid,mchpoi) 168 : return 169 : end 170 : 171 : 172 : 173 : 174 : 175 : 176 : 177 : 178 : 179 :
© Cast3M 2003 - All rights reserved.
Disclaimer