Télécharger nuperm.eso

Retour à la liste

Numérotation des lignes :

  1. C NUPERM SOURCE CHAT 06/03/29 21:28:41 5360
  2. C
  3.  
  4.  
  5.  
  6. C *****************************************************************
  7. C MODULE : ST (STRUCTURE DES DONNEES)
  8. C FICHIER : ST_NUMERO.F
  9. C OBJET : RENUMEROTE UN MAILLAGE 2D OU 3D
  10. C FONCT. :
  11. C NUPERM : PERMUTE 2 ELEMENTS D'UN MAILLAGE
  12. C NURENU : RENUMEROTE LES ELEMENTS D'UN MAILLAGE
  13. C NUCOMP : RENUMEROTE LES ELEMENTS D'UN MAILLAGE POUR LES
  14. C COMPACTER EN DEBUT : DE 1 A "NBNUM"
  15. C
  16. C AUTEUR : O. STAB
  17. C DATE : 03.95
  18. C TESTS : O.STAB 03.95
  19. C MODIFICATIONS :
  20. C AUTEUR, DATE, OBJET :
  21. C
  22. C
  23. C *****************************************************************
  24. C
  25. SUBROUTINE NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  26. > NOEMAX,NBE,IT1,IT2,iarr)
  27. C *****************************************************************
  28. C OBJET : PERMUTE 2 ELEMENTS D'UN MAILLAGE
  29. C EN ENTREE:
  30. C IDE : (1..3) DIMENSION DES ELEMENTS (POURRA SERVIR)
  31. C ITRNOE: LES NOEUDS DES ELEMENTS
  32. C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS
  33. C ITRTRI: LES VOISINS DES ELEMENTS
  34. C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS
  35. C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE
  36. C NBE : NOMBRE D'ELEMENTS DU MAILLAGE
  37. C IT1,IT2: LES 2 ELEMENTS A PERMUTER
  38. C EN SORTIE:
  39. C ITRNOE: MIS A JOUR
  40. C ITRTRI: MIS A JOUR
  41. C NOETRI : MIS A JOUR
  42. C iarr : CODE D'ERREUR 0 => OK
  43. C -1 => DONNEES INCOHERENTES
  44. C CONDITION D'APPLICATION : TOUT MAILLAGE
  45. C *****************************************************************
  46. IMPLICIT INTEGER(I-N)
  47. INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE
  48. INTEGER NOEMAX,IT1, IT2, iarr
  49. C
  50. INTEGER I,J,K,ITRTR2(6),ITRNO2(8),IT(3),ITR,IFRINT
  51. INTEGER NNT,NTRTRI(2*6,3)
  52. C
  53. iarr = 0
  54. IF( IT1 .EQ. IT2 )GO TO 999
  55. IF((IT1.LT.1).OR.(IT1.GT.NBE).OR.
  56. > (IT2.LT.1).OR.(IT2.GT.NBE))THEN
  57. iarr = -1
  58. CALL DSERRE(1,iarr,' NUPERM','NUMERO HORS INTERVAL')
  59. GO TO 999
  60. ENDIF
  61. C ---- MISE A JOUR DES REFERENC.OR.ES A IT1 ET IT2 ---
  62. IT(1) = IT1
  63. IT(2) = IT2
  64. IT(3) = IT1
  65. NNT = 0
  66. DO 10 K=1,2
  67. IF( NOEMAX .GT. 0 )THEN
  68. C -- MISE A JOUR DES NOEUDS FAISANT REFERENCE A IT1,IT2 ---
  69. DO 20 I=1,NBNMAX
  70. IF( NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) .EQ. IT(K) )
  71. > NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) = IT(K+1)
  72. 20 CONTINUE
  73. ENDIF
  74. C ---- MISE A JOUR DES ELEMENTS VOISINS DE IT1,IT2 ---
  75. DO 30 I=1,NBCMAX
  76. ITR = ITRTRI((IT(K)-1)*NBCMAX+I)
  77. IF((ITR.NE.0).AND.(ITR.NE.IT(K+1))
  78. > .AND.(ITR.NE.-IT(K+1)))THEN
  79. IFRINT = 1
  80. IF( ITR .LT. 0 )THEN
  81. IFRINT = -1
  82. ITR = - ITR
  83. ENDIF
  84. DO 40 J=1,NBCMAX
  85. IF( (ITRTRI((ITR-1)*NBCMAX+J).EQ.IT(K)) .OR.
  86. > (ITRTRI((ITR-1)*NBCMAX+J).EQ.-IT(K)) )THEN
  87. NNT = NNT + 1
  88. NTRTRI(NNT,1) = ITR
  89. NTRTRI(NNT,2) = J
  90. NTRTRI(NNT,3) = IFRINT * IT(K+1)
  91. C ITRTRI((ITR-1)*NBCMAX+J) = IFRINT * IT(K+1)
  92. GO TO 30
  93. ENDIF
  94. 40 CONTINUE
  95. C --- IL Y A UN BUG DANS LA STRUCTURE ---
  96. iarr = -1
  97. CALL DSERRE(1,iarr,' NUPERM',' STRUCTURE MAILLAGE')
  98. GO TO 999
  99. ENDIF
  100. 30 CONTINUE
  101. 10 CONTINUE
  102. C ------------------ MIS AJOUR DES VOISINS DE IT1,IT2 ---
  103. DO 45 I=1,NNT
  104. ITRTRI((NTRTRI(I,1)-1)*NBCMAX+NTRTRI(I,2))=NTRTRI(I,3)
  105. 45 CONTINUE
  106. C ------------------ SAUVEGARDE IT2 ---
  107. DO 50 I=1,NBCMAX
  108. IF( ITRTRI((IT2-1)*NBCMAX+I) .EQ. IT1 )THEN
  109. ITRTR2(I)=IT2
  110. ELSE IF( ITRTRI((IT2-1)*NBCMAX+I).EQ.-IT1)THEN
  111. ITRTR2(I)=-IT2
  112. ELSE
  113. ITRTR2(I)=ITRTRI((IT2-1)*NBCMAX+I)
  114. ENDIF
  115. 50 CONTINUE
  116. DO 60 I=1,NBNMAX
  117. ITRNO2(I)=ITRNOE((IT2-1)*NBNMAX+I)
  118. 60 CONTINUE
  119. C ---------- TRANSFERT IT1 -> IT2 ----------
  120. DO 70 I=1,NBCMAX
  121. IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. IT2 )THEN
  122. ITRTRI((IT2-1)*NBCMAX+I)=IT1
  123. ELSE IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. -IT2 )THEN
  124. ITRTRI((IT2-1)*NBCMAX+I)=-IT1
  125. ELSE
  126. ITRTRI((IT2-1)*NBCMAX+I)=ITRTRI((IT1-1)*NBCMAX+I)
  127. ENDIF
  128. 70 CONTINUE
  129. DO 80 I=1,NBNMAX
  130. ITRNOE((IT2-1)*NBNMAX+I)=ITRNOE((IT1-1)*NBNMAX+I)
  131. 80 CONTINUE
  132. C ---------- TRANSFERT IT2 -> IT1 ----------
  133. DO 90 I=1,NBCMAX
  134. ITRTRI((IT1-1)*NBCMAX+I)=ITRTR2(I)
  135. 90 CONTINUE
  136. DO 100 I=1,NBNMAX
  137. ITRNOE((IT1-1)*NBNMAX+I)=ITRNO2(I)
  138. 100 CONTINUE
  139. C ------------------
  140. 999 END
  141.  
  142.  
  143.  
  144.  

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