Télécharger comail.eso

Retour à la liste

Numérotation des lignes :

  1. C COMAIL SOURCE PV 09/03/12 21:17:20 6325
  2. SUBROUTINE COMAIL(iq1,iq2,ielin,ielout,icorre)
  3. * pour 2 meleme de meme type construit un melval en allant piocher
  4. * dans le melval initial si les elements sont les memes
  5. *
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8. -INC CCOPTIO
  9. -INC SMELEME
  10. -INC SMCHAML
  11. -INC SMLENTI
  12. -INC SMCOORD
  13.  
  14. segment ipos(xcoor(/1)/(idim+1)+1)
  15. segment ind(mm)
  16. segment icorre
  17. integer mel2(nmel1),icor(nmel1),idej
  18. endsegment
  19. logical iperm
  20. *
  21. *
  22. meleme=iq1
  23. ipt1=iq2
  24. ielout=0
  25. nbsous1 = ipt1.lisous(/1)
  26. nbnn = num(/1)
  27. nbnn1 = ipt1.num(/1)
  28. if (nbsous1.ne.0.OR.nbnn1.ne.nbnn) then
  29. * pas normal
  30. moterr(1:8) ='COMAIL'
  31. interr(1) = 1
  32. call erreur(-329)
  33. return
  34. endif
  35. do iou=1,idej
  36. if(ipt1.eq.mel2(iou)) then
  37. if(icor(iou).eq.0) then
  38. return
  39. else
  40. mlenti=icor(iou)
  41. segact mlenti
  42. go to 100
  43. endif
  44. endif
  45. enddo
  46. * on dimensionne au nombre d elements du meleme
  47. jg= num(/2)
  48. segini mlenti
  49. * travail preparatoire
  50. segini ipos
  51. np=ipos(/1)-1
  52. do 10 i=1,num(/2)
  53. do 11 j=1,num(/1)
  54. ia=num(j,i)
  55. ipos(ia)=ipos(ia)+1
  56. 11 continue
  57. 10 continue
  58. * on initialise ipos
  59. do 13 i=2,np
  60. ipos(i)=ipos(i-1)+ipos(i)
  61. 13 continue
  62. ipos(np+1)=ipos(np)
  63. * remplissage de ind
  64. mm=ipos(np)
  65. segini ind
  66. do 20 i=1,num(/2)
  67. do 21 j=1,num(/1)
  68. ia=num(j,i)
  69. ide=ipos(ia)
  70. ind(ide)=i
  71. ipos(ia)=ipos(ia)-1
  72. 21 continue
  73. 20 continue
  74. * fin du travail preparatoire
  75.  
  76. C on fabrique le mlenti de correspondance
  77. ibon=0
  78. do 15 iel1=1,ipt1.num(/2)
  79. ia= ipt1.num(1,iel1)
  80. ideb=ipos(ia)+1
  81. ifin=ipos(ia+1)
  82. if(ifin.lt.ideb) go to 15
  83. do 16 ie=ideb,ifin
  84. iel=ind(ie)
  85. do inn=1,nbnn
  86. if(num(inn,iel).ne.ipt1.num(inn,iel1))go to 16
  87. enddo
  88. ibon=1
  89. lect(iel)=iel1
  90. go to 15
  91. 16 continue
  92. 15 continue
  93. segsup ind,ipos
  94. idej=idej+1
  95. if(idej.gt.mel2(/1)) then
  96. nmel1=mel2(/1)+50
  97. segadj icorre
  98. endif
  99. mel2(idej)=ipt1
  100. if(ibon.eq.0) then
  101. return
  102. endif
  103. icor(idej)=mlenti
  104. 100 continue
  105. melva1 = ielin
  106. segact melva1
  107. n1ptel = melva1.velche(/1)
  108. n1el = num(/2)
  109. n2ptel = melva1.ielche(/1)
  110. n2el = num(/2)
  111. segini melval
  112.  
  113. do ielem=1,num(/2)
  114. iel1=lect(ielem)
  115. if (n2ptel.eq.0.and.n2el.eq.0) then
  116. do iptel = 1, n1ptel
  117. velche(iptel,ielem) = melva1.velche(iptel,iel1)
  118. enddo
  119. elseif (n1ptel.eq.0.and.n1el.eq.0) then
  120. do iptel = 1,n2ptel
  121. ielche(iptel,ielem) = melva1.ielche(iptel,iel1)
  122. enddo
  123. endif
  124. enddo
  125. segdes melval,melva1
  126. ielout=melval
  127. RETURN
  128. END
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  

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