Télécharger dbbcd.eso

Retour à la liste

Numérotation des lignes :

  1. C DBBCD SOURCE PV 07/08/03 21:15:03 5835
  2. * dedualise les valeurs d'un champ en fonction d'un meleme de dedoublement de noeuds
  3. *
  4. subroutine dbbcd(mchpoi,ipt8)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. -INC CCOPTIO
  8. -INC SMELEME
  9. -INC SMCHPOI
  10. -INC SMCOORD
  11. segment valc(ipt8.num(/2))
  12. segment ivalc(ipt8.num(/2))
  13. segment trav
  14. integer lag1(xcoor(/1)/(idim+1))
  15. endsegment
  16. * ne fonctionne que pour des FLX, on suppose qu'il n'y a qu'une inconnue
  17. * par noeud dédoublé
  18. if (ipt8.eq.0) return
  19. segact mchpoi,ipt8
  20. ** call echpo(mchpoi,1)
  21. ** call ecmail(ipt8,1)
  22. ** segact mchpoi,ipt8
  23. segini valc,ivalc
  24. segini trav
  25. do 300 i=1,ipt8.num(/2)
  26. lag1(ipt8.num(1,i))=i
  27. lag1(ipt8.num(2,i))=i
  28. 300 continue
  29. do 10 isoupo=1,ipchp(/1)
  30. msoupo=ipchp(isoupo)
  31. segact msoupo*mod
  32. if (nocomp(/2).ne.1) goto 11
  33. if (nocomp(1).ne.'FLX') goto 11
  34. meleme=igeoc
  35. mpoval=ipoval
  36. segini,ipt1=meleme,mpova1=mpoval
  37. nbnn=ipt1.num(/1)
  38. nbelem=ipt1.num(/2)
  39. nbele=nbelem
  40. nbsous=0
  41. nbref=0
  42. ic=0
  43. do 100 j=1,nbele
  44. val=mpova1.vpocha(j,1)
  45. if (lag1(ipt1.num(1,j)).ne.0) then
  46. jj=lag1(ipt1.num(1,j))
  47. valc(jj)= +val
  48. if (ivalc(jj).ne.0) then
  49. ipt1.num(1,ivalc(jj))=ipt8.num(1,jj)
  50. mpova1.vpocha(ivalc(jj),1)=valc(jj)
  51. goto 100
  52. endif
  53. ivalc(jj)=ic+1
  54. endif
  55. 110 continue
  56. ic=ic+1
  57. ipt1.num(1,ic)=ipt1.num(1,j)
  58. mpova1.vpocha(ic,1)=val
  59. 100 continue
  60. nbelem=ic
  61. segadj ipt1
  62. segdes ipt1
  63. n=ic
  64. nc=1
  65. segadj mpova1
  66. segdes mpova1
  67. igeoc=ipt1
  68. ipoval=mpova1
  69. segsup mpoval
  70. segdes meleme
  71. 11 continue
  72. segdes msoupo
  73. 10 continue
  74. segsup valc,ivalc,trav
  75. return
  76. end
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  

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