Télécharger ordon4.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON4 SOURCE PV 16/11/26 21:16:16 9205
  2. SUBROUTINE ORDON4 (MELEME)
  3. ************************************************************************
  4. * O R D O N N
  5. * -----------
  6. * SOUS-PROGRAMME ASSOCIE A LA DIRECTIVE "ORDONNER"
  7. * FONCTION:
  8. * ---------
  9. * reordonner une ligne de seg2 ou seg3
  10. *
  11. * on ordonne selon la proximite au premier pt pour des POI1 (PP 97)
  12. *
  13. C+PP
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8 (A-H,O-Z)
  16. DIMENSION P(3)
  17. real*8 DIST2
  18. integer i, ia, ico, iCompl, ie1, ie2, iref, j, jg, p
  19. integer iPile,nbElem
  20. C+PP
  21. -INC CCOPTIO
  22. -INC COCOLL
  23. -INC SMELEME
  24. C+PP
  25. -INC SMLREEL
  26. -INC SMLENTI
  27. -INC SMCOORD
  28. -INC TMCOLAC
  29.  
  30. SEGMENT TTRAV
  31. INTEGER ILIS(NNOE)
  32. ENDSEGMENT
  33.  
  34. pointeur piles.LISPIL
  35. pointeur jcolac.ICOLAC
  36. pointeur jlisse.ILISSE
  37. pointeur jtlacc.ITLACC
  38.  
  39. C+PP
  40. *
  41. * on verifie d'abord que l'objet est simple
  42. *
  43. icompl=0
  44. SEGACT MELEME
  45. IF(LISOUS(/1).NE.0.OR.ITYPEL.GT.3) then
  46. CALL RENUEL(MELEME)
  47. return
  48. endif
  49. C+PP
  50. IF(ITYPEL.EQ.1)THEN
  51. SEGACT,MELEME*MOD
  52. NBELEM=ICOLOR(/1)
  53. C Si le nombre d'éléments POI1 est inférieur ou égal à 2
  54. C Il n'y a rien à faire
  55. IF(NBELEM.LE.2) GOTO 9998
  56. IREF=NUM(1,1)
  57. IREF=(IDIM+1)*(IREF-1)
  58. DO IE1=1,IDIM
  59. P(IE1)=XCOOR(IREF+IE1)
  60. ENDDO
  61. JG=NBELEM-1
  62. SEGINI,MLREEL,MLENTI
  63. DO IE1=1,JG
  64. IREF=NUM(1,IE1+1)
  65. LECT(IE1)=IREF
  66. IREF=(IDIM+1)*(IREF-1)
  67. DIST2=0.D0
  68. DO IE2=1,IDIM
  69. DIST2=DIST2+(P(IE2)-XCOOR(IREF+IE2))**2
  70. ENDDO
  71. PROG(IE1)=DIST2
  72. ENDDO
  73. CALL GENOS2(PROG,LECT,JG)
  74. DO IE1=1,JG
  75. NUM(1,IE1+1)=LECT(IE1)
  76. ENDDO
  77. SEGSUP,MLREEL,MLENTI
  78. ELSE
  79. C+PP
  80. CALL LIGMAI(MELEME,TTRAV,0)
  81. IF(IERR.NE.0) RETURN
  82. SEGACT TTRAV
  83. SEGACT MELEME*MOD
  84. IA=1
  85. DO 1 I=1,NUM(/2)
  86. IA=IA-1
  87. DO 2 J=1,NUM(/1)
  88. IA=IA+1
  89. NUM(J,I)=ILIS(IA)
  90. 2 CONTINUE
  91. 1 CONTINUE
  92. SEGSUP TTRAV
  93. ENDIF
  94. 9998 CONTINUE
  95. SEGDES,MELEME
  96. c
  97. IF(IPSAUV.NE.0) THEN
  98. ICOLAC = IPSAUV
  99. SEGACT ICOLAC
  100. ILISSE=ILISSG
  101. SEGACT ILISSE*MOD
  102. CALL TYPFIL('MAILLAGE',ICO)
  103. ITLACC = KCOLA(ICO)
  104. SEGACT ITLACC*MOD
  105. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  106. SEGDES ICOLAC,ILISSE
  107. ENDIF
  108. C Suppression des piles d'objets communiques
  109. if(piComm.gt.0) then
  110. piles=piComm
  111. segact piles
  112. call typfil('MAILLAGE',ico)
  113. do ipile=1,piles.proc(/1)
  114. jcolac= piles.proc(ipile)
  115. if(jcolac.ne.0) then
  116. segact jcolac
  117. jlisse=jcolac.ilissg
  118. segact jlisse*mod
  119. jtlacc=jcolac.kcola(ico)
  120. segact jtlacc*mod
  121. call ajoun0(jtlacc,MELEME,jlisse,1)
  122. segdes jtlacc
  123. segdes jlisse
  124. segdes jcolac
  125. endif
  126. enddo
  127. segdes piles
  128. endif
  129. RETURN
  130. END
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  

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