Télécharger mucpri.eso

Retour à la liste

Numérotation des lignes :

  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
  164. call crech1(meleme,1)
  165. igeoc=meleme
  166. 170 continue
  167. segsup itrav1,itrav2,itrav4
  168. 1000 continue
  169. call mucpr1(mchpo1,mrigid,mchpoi)
  170. return
  171. end
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  

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