1 : C FPSHB8 SOURCE CHAT 11/03/16 21:23:09 6902 2 : subroutine fpshb8(mmodel,mchpo1,p,mchpoi) 3 : implicit real*8(a-h,o-z) 4 : implicit integer (i-n) 5 : -INC CCOPTIO 6 : -INC SMCHPOI 7 : -INC SMELEME 8 : -INC SMMODEL 9 : -INC SMCOORD 10 : character*4 moopt(2) 11 : segment tratra 12 : real *8 propel(2),out(3,8),re(1),d(1),xe(3,8),work(3) 13 : endsegment 14 : segment icpr(xcoor(/1)/(idim+1)) 15 : segment icprp(xcoor(/1)/(idim+1)) 16 : data moopt/'INTE','EXTE'/ 17 : * 18 : * verif que les surfaces interne ou externe existent 19 : * 20 : icpr=0 21 : icprp=0 22 : mchpoi=0 23 : segact mmodel 24 : do ia=1,kmodel(/1) 25 : imodel=kmodel(ia) 26 : segact imodel 27 : if(nefmod.ne.260) then 27 : call erreur (19) 28 : return 29 : endif 30 : meleme=imamod 31 : segact meleme 32 : if(lisref(/1).ne.2) then 32 : call erreur(1004) 33 : return 34 : endif 35 : ipt1=lisref(1) 36 : segact ipt1 37 : if(ipt1.itypel.ne.8) then 37 : call erreur (1004) 38 : return 39 : endif 40 : segdes ipt1 41 : ipt1=lisref(2) 42 : segact ipt1 43 : if(ipt1.itypel.ne.8) then 43 : call erreur (1004) 44 : return 45 : endif 46 : segdes ipt1 47 : enddo 48 : * 49 : * reperage du champpointy de pression si necessaire 50 : * 51 : if( mchpo1.ne.0) then 52 : segini icpr 53 : segact mchpo1 54 : if(mchpo1.ipchp(/1).ne.1) then 54 : call erreur(180) 55 : mchpoi=0 56 : return 57 : endif 58 : msoupo=mchpo1.ipchp(1) 59 : segact msoupo 60 : ipt1=igeoc 61 : segact ipt1 62 : do i=1,ipt1.num(/2) 63 : ia=ipt1.num(1,i) 64 : icpr(ia)=i 65 : enddo 66 : mpova2=ipoval 67 : segact mpova2 68 : segdes msoupo,ipt1 69 : endif 70 : * 71 : * lecture du mot interne ou externe et debut de la 72 : * fabrication du chpoint résultat 73 : * 73 : call lirmot(moopt,2,isur,0) 74 : if(isur.eq.0) then 75 : * on a pas lu ni interne ni externe on essaye de savoir 76 : * sur qui le chpoint de pression est appliqué 77 : if(mchpo1.eq.0) then 77 : call erreur(1005) 78 : return 79 : endif 80 : isur1=0 81 : do ia=1,kmodel(/1) 82 : imodel=kmodel(ia) 83 : meleme=imamod 84 : do 321 io=1,2 85 : ipt3=lisref(io) 86 : segact ipt3 87 : do iel=1,ipt3.num(/2) 88 : iell=ipt3.num(1,iel) 89 : if( icpr(iell).eq.0) go to 321 90 : enddo 91 : if(isur1.eq.0) then 92 : isur1=io 93 : go to 322 94 : else 95 : if(isur1.ne.io)then 95 : call erreur(1006) 96 : return 97 : endif 98 : endif 99 : 321 continue 100 : 322 continue 101 : enddo 101 : if(isur1.eq.0) call erreur(286) 102 : isur=isur1 103 : endif 104 : * 105 : * reperage de la surface 106 : * 107 : segini icprp 108 : nbelem=0 109 : do ia=1,kmodel(/1) 110 : imodel=kmodel(ia) 111 : meleme=imamod 112 : ipt3=lisref(isur) 113 : segact ipt3 114 : do ib=1,ipt3.num(/2) 115 : do ic=1,ipt3.num(/1) 116 : ie=ipt3.num(ic,ib) 117 : if(icprp(ie).eq.0) then 118 : nbelem=nbelem+1 119 : icprp(ie)=nbelem 120 : endif 121 : enddo 122 : enddo 123 : enddo 124 : * 125 : * debut de la fabrication du chpoint résultat 126 : * 127 : nbnn=1 128 : nbref=0 129 : nbsous=0 130 : segini ipt4 131 : nsoupo=1 132 : nat=1 133 : segini mchpoi 134 : ifopoi=ifour 135 : mtypoi='FORCES' 136 : mochde='crée par fpshb8 ' 137 : nc=3 138 : segini msoupo 139 : ipchp(1)=msoupo 140 : segdes mchpoi 141 : n=nbelem 142 : segini mpoval 143 : ipoval=mpoval 144 : igeoc=ipt4 145 : nocomp(1)='F ' 146 : nocomp(2)='FY ' 147 : nocomp(3)='FZ ' 148 : noharm(1)=nifour 149 : noharm(2)=nifour 150 : noharm(3)=nifour 151 : segdes msoupo 152 : do ib=1,icprp(/1) 153 : ia=icprp(ib) 154 : if(ia.ne.0) ipt4.num(1,ia)=ib 155 : enddo 156 : segdes ipt4 157 : * 158 : * boucle sur les élements 159 : * 160 : segini tratra 161 : idim1=idim+1 162 : do ir=1,kmodel(/1) 163 : imodel=kmodel(ir) 164 : meleme=imamod 165 : segact meleme 166 : ipt3=lisref(isur) 167 : segact ipt3 168 : propel(2)=isur 169 : propel(1)=p 170 : do iel=1,num(/2) 171 : if( mchpo1.ne.0) then 172 : p=0.d0 173 : do j=1,ipt3.num(/1) 174 : ih=ipt3.num(j,iel) 175 : if(icpr(ih).ne.0) then 176 : p=p+mpova2.vpocha(icpr(ih),1)/4 177 : endif 178 : enddo 179 : propel(1)=p 180 : endif 181 : do io=1,8 182 : ia=num(io,iel) 183 : xe(1,io)=xcoor((ia-1)*idim1+1) 184 : xe(2,io)=xcoor((ia-1)*idim1+2) 185 : xe(3,io)=xcoor((ia-1)*idim1+3) 186 : enddo 186 : call shb8(5,xe,D,propel,work,re,out) 187 : * assemblage 188 : 189 : do io=1,8 190 : ia=num(io,iel) 191 : ib=icprp(ia) 192 : if(ib.ne.0) then 193 : vpocha(ib,1)=out(1,io)+vpocha(ib,1) 194 : vpocha(ib,2)=out(2,io)+vpocha(ib,2) 195 : vpocha(ib,3)=out(3,io)+vpocha(ib,3) 196 : endif 197 : enddo 198 : enddo 199 : segdes imodel,meleme,ipt3 200 : enddo 201 : segdes mpoval 202 : segdes mmodel 203 : segsup icprp,tratra 204 : if(icpr.ne.0) then 205 : segsup icpr 206 : segdes mpova2 207 : endif 208 : return 209 : end 210 : 211 : 212 :
© Cast3M 2003 - All rights reserved.
Disclaimer