Télécharger dbbch.eso

Retour à la liste

Numérotation des lignes :

  1. C DBBCH SOURCE PV 18/11/07 21:15:01 9986
  2. * dualise les valeurs d'un champ en fonction d'un meleme de dedoublement de noeuds
  3. *
  4. subroutine dbbch(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 trav
  12. integer lag1(xcoor(/1)/(idim+1))
  13. integer lag2(xcoor(/1)/(idim+1))
  14. endsegment
  15. * ne fonctionne que pour des LX, on suppose qu'il n'y a qu'une include
  16. * par noeud dédoublé
  17. * on verifie que le noeud dedouble n'est pas deja dans le champ
  18. if (ipt8.eq.0) return
  19. segini trav
  20. segact mchpoi,ipt8
  21. * call ecchpo(mchpoi,0)
  22. * call ecmail(ipt8,0)
  23. segact mchpoi,ipt8
  24. do 300 i=1,ipt8.num(/2)
  25. lag1(ipt8.num(1,i))=ipt8.num(2,i)
  26. 300 continue
  27. do 310 isoupo=1,ipchp(/1)
  28. msoupo=ipchp(isoupo)
  29. segact msoupo
  30. if (nocomp(/2).ne.1) goto 310
  31. if (nocomp(1).ne.'FLX') goto 310
  32. meleme=igeoc
  33. segact meleme
  34. do 311 i=1,num(/2)
  35. lag2(num(1,i))=i
  36. 311 continue
  37. 310 continue
  38. do 10 isoupo=1,ipchp(/1)
  39. msoupo=ipchp(isoupo)
  40. segact msoupo*mod
  41. if (nocomp(/2).ne.1) goto 10
  42. if (nocomp(1).ne.'FLX') goto 10
  43. meleme=igeoc
  44. mpoval=ipoval
  45. segact meleme,mpoval*mod
  46. nbnn=num(/1)
  47. nbelem=num(/2)
  48. nbele=nbelem
  49. nbsous=0
  50. nbref=0
  51. segini,ipt1=meleme
  52. segdes meleme
  53. meleme=ipt1
  54. igeoc=meleme
  55. * on fait les meleme et mpoval 2 fois plus grand et ont les ajuste a la fin
  56. nbelem=nbelem*2
  57. segadj meleme
  58. n=nbelem
  59. nc=1
  60. segadj mpoval
  61. nbelem=nbele
  62. do 100 j=1,nbele
  63. if (lag1(num(1,j)).eq.0) goto 110
  64. * write (6,*) ' num lag1 lag2 ',num(1,j),lag1(num(1,j)),
  65. * > lag2(lag1(num(1,j)))
  66. if (lag2(lag1(num(1,j))).ne.0) then
  67. * write (6,*) ' vpocha ',vpocha(j,1),
  68. * > vpocha(lag2(lag1(num(1,j))),1)
  69. interr(1)=lag1(num(1,j))
  70. interr(2)=lag2(lag1(num(1,j)))
  71. call erreur(1001)
  72. goto 110
  73. endif
  74. nbelem=nbelem+1
  75. num(1,nbelem)=lag1(num(1,j))
  76. vpocha(nbelem,1)=vpocha(j,1)
  77. * write (6,*) ' noeu ',num(1,j),' valeur ',vpocha(j,1),num(1,nbelem)
  78. goto 100
  79. 110 continue
  80. 100 continue
  81. segadj meleme
  82. n=nbelem
  83. nc=1
  84. segadj mpoval
  85. 10 continue
  86. segsup trav
  87. return
  88. end
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  

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