Télécharger dbbch.eso

Retour à la liste

Numérotation des lignes :

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

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