Télécharger ordon4.eso

Retour à la liste

Numérotation des lignes :

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

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