Télécharger dbbch.eso

Retour à la liste

Numérotation des lignes :

  1. C DBBCH SOURCE PV 13/04/12 21:15:25 7756
  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. do 100 j=1,nbele
  56. if (lag1(num(1,j)).eq.0) goto 110
  57. * write (6,*) ' num lag1 lag2 ',num(1,j),lag1(num(1,j)),
  58. * > lag2(lag1(num(1,j)))
  59. if (lag2(lag1(num(1,j))).ne.0) then
  60. * write (6,*) ' vpocha ',vpocha(j,1),
  61. * > vpocha(lag2(lag1(num(1,j))),1)
  62. interr(1)=lag1(num(1,j))
  63. interr(2)=lag2(lag1(num(1,j)))
  64. call erreur(1001)
  65. goto 110
  66. endif
  67. nbelem=nbelem+1
  68. segadj meleme
  69. num(1,nbelem)=lag1(num(1,j))
  70. n=nbelem
  71. nc=1
  72. segadj mpoval
  73. vpocha(nbelem,1)=vpocha(j,1)
  74. * write (6,*) ' noeu ',num(1,j),' valeur ',vpocha(j,1),num(1,nbelem)
  75. goto 100
  76. 110 continue
  77. 100 continue
  78. 10 continue
  79. segsup trav
  80. return
  81. end
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  

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