Télécharger xty1.eso

Retour à la liste

Numérotation des lignes :

  1. C XTY1 SOURCE GF238795 18/02/01 21:16:35 9724
  2. subroutine xty1(mchpot,ich2,mlmotx,mlmoty,xret)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. INTEGER NBO
  6. -INC CCOPTIO
  7. -INC SMCHPOI
  8. -INC SMLMOTS
  9. -INC SMELEME
  10. -INC SMCOORD
  11. segment itrav
  12. * izon : num de zone dans 2 chp d'un point
  13. * ipos : num de pt dans zone d'un point
  14. *
  15. integer izon(nbpts),ipos(nbpts)
  16. *
  17. * nbop : nb de terme dans produit 1-zonei 2-zonej
  18. *
  19. integer nbop(nbz1,nbz2)
  20. *
  21. * icpos1 icpos2 : num composante zone a traiter
  22. *
  23. integer icpos1(nbopma,nbz1,nbz2),icpos2(nbopma,nbz1,nbz2)
  24. *
  25. endsegment
  26. *
  27. NBO=0
  28. xret=0.d0
  29. *
  30. * creation de itrav
  31. *
  32. nbpts=xcoor(/1)/(idim+1)
  33. mlmot1=mlmotx
  34. segact mlmot1
  35. nbopma=mlmot1.mots(/2)
  36. mlmot2=mlmoty
  37. segact mlmot2
  38. if (nbopma.ne.mlmot2.mots(/2)) call erreur(217)
  39. if (ierr.ne.0) return
  40. mchpo1=mchpot
  41. segact mchpo1
  42. nbz1=mchpo1.ipchp(/1)
  43. mchpo2=ich2
  44. segact mchpo2
  45. nbz2=mchpo2.ipchp(/1)
  46. segini itrav
  47. *
  48. * remplissage de itrav a partir du deuxieme champ
  49. *
  50. do 10 isoupo=1,nbz2
  51. msoup2=mchpo2.ipchp(isoupo)
  52. segact msoup2
  53. mpova2=msoup2.ipoval
  54. segact mpova2
  55. ipt2=msoup2.igeoc
  56. segact ipt2
  57. do 15 iel=1,ipt2.num(/2)
  58. ip=ipt2.num(1,iel)
  59. izon(ip)=isoupo
  60. ipos(ip)=iel
  61. 15 continue
  62. 10 continue
  63. *
  64. * travail effectif : boucle su r le premier chpoint
  65. * on fabriquera au vol les nbop icpos1 et icpos2 si necessaire
  66. *
  67. do 20 isoupo=1,nbz1
  68. msoup1=mchpo1.ipchp(isoupo)
  69. segact msoup1
  70. mpova1=msoup1.ipoval
  71. segact mpova1
  72. ipt1=msoup1.igeoc
  73. segact ipt1
  74. ieldin=1
  75. 100 continue
  76. do 110 ieldeb=ieldin,ipt1.num(/2)
  77. izocou=izon(ipt1.num(1,ieldeb))
  78. if(izocou.ne.0) goto 115
  79. 110 continue
  80. goto 20
  81. 115 continue
  82. msoup2=mchpo2.ipchp(izocou)
  83. if (nbop(isoupo,izocou).eq.0) then
  84. do 30 im=1,nbopma
  85. do 35 ic1=1,msoup1.nocomp(/2)
  86. if (mlmot1.mots(im).eq.msoup1.nocomp(ic1)) goto 40
  87. 35 continue
  88. goto 30
  89. 40 continue
  90. do 45 ic2=1,msoup2.nocomp(/2)
  91. if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2)) goto 45
  92. if (mlmot2.mots(im).eq.msoup2.nocomp(ic2)) goto 50
  93. 45 continue
  94. goto 30
  95. 50 continue
  96. nbo=nbop(isoupo,izocou)+1
  97. nbop(isoupo,izocou)=nbo
  98. icpos1(nbo,isoupo,izocou)=ic1
  99. icpos2(nbo,isoupo,izocou)=ic2
  100. 30 continue
  101. if (nbo.eq.0) nbop(isoupo,izocou)=-1
  102. endif
  103. do 60 ielcou=ieldeb+1,ipt1.num(/2)
  104. ipt=ipt1.num(1,ielcou)
  105. izon2=izon(ipt)
  106. if (izon2.ne.izocou) goto 70
  107. 60 continue
  108. ielcou=ipt1.num(/2)+1
  109. 70 continue
  110. mpova2=msoup2.ipoval
  111. do 80 ic=1,nbop(isoupo,izocou)
  112. ic1=icpos1(ic,isoupo,izocou)
  113. ic2=icpos2(ic,isoupo,izocou)
  114. do 90 iel=ieldeb,ielcou-1
  115. xret=xret+mpova1.vpocha(iel,ic1)*
  116. > mpova2.vpocha(ipos(ipt1.num(1,iel)),ic2)
  117. 90 continue
  118. 80 continue
  119. ieldin=ielcou
  120. if (ieldin.le.ipt1.num(/2)) goto 100
  121. segdes msoup1,mpova1,ipt1
  122. 20 continue
  123. * c'est fini on nettoie
  124. segsup itrav
  125. if (mchpo1.ne.mchpo2) then
  126. do 150 isoupo=1,nbz2
  127. msoup2=mchpo2.ipchp(isoupo)
  128. mpova2=msoup2.ipoval
  129. segdes mpova2
  130. ipt2=msoup2.igeoc
  131. segdes ipt2
  132. segdes msoup2
  133. 150 continue
  134. endif
  135. segdes mchpo1,mchpo2,mlmot1,mlmot2
  136. return
  137. end
  138.  
  139.  
  140.  
  141.  

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