Télécharger dbbcd.eso

Retour à la liste

Numérotation des lignes :

  1. C DBBCD SOURCE PV 20/03/30 21:17:22 10567
  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(nbpts)
  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.  
  84.  

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