Télécharger mucpri.eso

Retour à la liste

Numérotation des lignes :

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

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