Télécharger mucpri.eso

Retour à la liste

Numérotation des lignes :

  1. C MUCPRI SOURCE PV 17/06/16 14:33:50 9460
  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 cnoha
  30. integer*4 inoha
  31. equivalence (cnoha,inoha)
  32. data cnoha/'NOHA'/
  33. *
  34. * constitution de la liste des composantes duales
  35. *
  36. nbpts=xcoor(/1)/(idim+1)
  37. segact mrigid
  38. nrigel=irigel(/2)
  39. if (imgeo2.ne.0) goto 1000
  40. * creation d'un champoin prototype
  41. * attention les mpoval ne sont pas crees
  42. segact mrigid*mod
  43. nctod=0
  44. do 27 irige=1,nrigel
  45. descr=irigel(3,irige)
  46. segact descr
  47. nctod=nctod+lisdua(/2)
  48. 27 continue
  49. segini itrav1
  50. nctod=0
  51. do 30 irige=1,nrigel
  52. descr=irigel(3,irige)
  53. do 32 i=1,lisdua(/2)
  54. do 33 j=1,nctod
  55. if (ifod(j).ne.irigel(5,irige)) goto 33
  56. if (nocod(j).eq.lisdua(i)) goto 31
  57. 33 continue
  58. nctod=nctod+1
  59. nocod(nctod)=lisdua(i)
  60. ifod(nctod)=irigel(5,irige)
  61. 31 continue
  62. 32 continue
  63. 30 continue
  64. *
  65. * expansion du chpo dual de la rigidite
  66. *
  67. segini itrav4
  68. do 40 irige=1,nrigel
  69. descr=irigel(3,irige)
  70. ipt2=irigel(1,irige)
  71. segact ipt2
  72. do 45 ic=1,lisdua(/2)
  73. do 47 ir=1,nctod
  74. if (ifod(ir).ne.irigel(5,irige)) goto 47
  75. if (nocod(ir).eq.lisdua(ic)) goto 50
  76. 47 continue
  77. goto 45
  78. 50 continue
  79. if (irigel(5,irige).eq.inoha) then
  80. ivava=2**17+2**16
  81. else
  82. ivava=2**17+ifod(ir)
  83. endif
  84. do 55 iel=1,ipt2.num(/2)
  85. ivald(ir,ipt2.num(noeled(ic),iel))=ivava
  86. 55 continue
  87. 45 continue
  88. 40 continue
  89. *
  90. * creation du champoin resultant (sans les valeurs)
  91. *
  92. nat=1
  93. nsoupo=0
  94. segini mchpoi,itrav2
  95. segact mchpo1
  96. * jattri(1) = (mchpo1.jattri(1) * 4 )/ 2
  97. * par defaut les chpts issus d'un produit seront discret! PV
  98. jattri(1) = 2
  99. mochde='créé par mucpri'
  100. mtypoi=' '
  101. ifopoi=mchpo1.ifopoi
  102. * on sauve de suite dans la raideur le prototype
  103. imgeo2=mchpoi
  104. *
  105. do 100 i=1,nbpts
  106. do 110 ir=1,nctod
  107. if (ivald(ir,i).ne.0) goto 120
  108. 110 continue
  109. goto 100
  110. 120 continue
  111. * point a garder test liste des composantes
  112. do 130 isoupo=ipchp(/1),1,-1
  113. msoupo=ipchp(isoupo)
  114. * regarder si meme composantes et harmonique que isoupo
  115. do 140 ic=1,nocomp(/2)
  116. if (ivald(liscomp(ic,isoupo),i).ne.2**17+noharm(ic)) goto 130
  117. 140 continue
  118. * verifier pas d'autres composantes
  119. indtot=0
  120. do 145 ir=1,nctod
  121. if (ivald(ir,i).ne.0) indtot=indtot+1
  122. 145 continue
  123. if (indtot.ne.nocomp(/2)) goto 130
  124. * ok on ajoute le pt dans sa liste
  125. nbp(isoupo)=nbp(isoupo)+1
  126. meleme=igeoc
  127. num(1,nbp(isoupo))=i
  128. goto 100
  129. 130 continue
  130. * creation d'un nouveau paquet
  131. 150 continue
  132. nsoupo=nsoupo+1
  133. segadj mchpoi,itrav2
  134. nc=0
  135. do 160 ir=1,nctod
  136. if (ivald(ir,i).eq.0) goto 160
  137. nc=nc+1
  138. liscomp(nc,nsoupo)=ir
  139. 160 continue
  140. segini msoupo
  141. ipchp(nsoupo)=msoupo
  142. do 165 ic=1,nc
  143. nocomp(ic)=nocod(liscomp(ic,nsoupo))
  144. noharm(ic)=ifod(liscomp(ic,nsoupo))
  145. 165 continue
  146. nbelem=nbpts
  147. nbnn=1
  148. nbsous=0
  149. nbref=0
  150. segini meleme
  151. itypel=1
  152. igeoc=meleme
  153. num(1,1)=i
  154. nbp(nsoupo)=1
  155. goto 100
  156. 100 continue
  157. do 170 isoup=1,nsoupo
  158. msoupo=ipchp(isoup)
  159. meleme=igeoc
  160. nbelem=nbp(isoup)
  161. nbnn=1
  162. nbsous=0
  163. nbref=0
  164. segadj meleme
  165. * si possible ne pas creer de nouveau meleme
  166. call crech1(meleme,1)
  167. igeoc=meleme
  168. 170 continue
  169. segsup itrav1,itrav2,itrav4
  170. 1000 continue
  171. call mucpr1(mchpo1,mrigid,mchpoi)
  172. return
  173. end
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales