Télécharger elimin.eso

Retour à la liste

Numérotation des lignes :

  1. C ELIMIN SOURCE CB215821 16/07/18 21:15:00 9033
  2. C
  3. SUBROUTINE ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C======================================================================
  7. C FUSION DES NOEUDS AYANT DES COORDONNEES TROP VOISINES
  8. C UTILISE PAR L'OPERATEUR ELIM ICLE=0 ET PAR L'OPERATEUR VISA ICLE=1
  9. C APPEL PRELIMINAIRE DE PRELIM QUI CREE LES TABLEAUX
  10. C
  11. C ICPR EST LA MOUVELLE NUMEROTATION
  12. C ICPR(ANCIEN N°)= NOUVEAU N°
  13. C ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S
  14. C ) ARGUMENT(S)
  15. C IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
  16. C =1 SI LE NOEUD EST DANS LE 1ER MAILLGE =0 SINON
  17. C =2 SI LE NOEUD SUPPORTE UN MULTIPLICATEUR
  18. C IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
  19. C =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE =0 SINON
  20. C======================================================================
  21. -INC CCOPTIO
  22. -INC SMCOORD
  23.  
  24. -INC SMLENTI
  25. -INC SMELEME
  26. POINTEUR MELEM2.MELEME
  27. SEGMENT /STRAV/(NP1(ITF),NP2(ITF),NP3(ITF),NPI(ITF),IDCP(ITF),
  28. & NP4(ITF),NP5(ITF))
  29. SEGMENT ICPR(1)
  30. SEGMENT IAPOB1(1)
  31. SEGMENT IAPOB2(1)
  32. SEGMENT ITLAC(0)
  33. INTEGER TRUC,TRUC1,TRUC3
  34. G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F))
  35. C======================================================================
  36. SEGACT MCOORD*MOD
  37. IF (ITE.LE.1) RETURN
  38. ITF=ITE+3+1
  39. SEGINI STRAV
  40. * IDCP = tableau reciproque de ICPR
  41. DO 250 I=1,ICPR(/1)
  42. IF (ICPR(I).NE.0) IDCP(ICPR(I))=I
  43. 250 CONTINUE
  44. NUMNP=ITE
  45. PREC=CRIT
  46. PREC2=PREC*PREC
  47. NCO2=0
  48. DO 5 I=1,NUMNP
  49. NPI(I)=I
  50. 5 CONTINUE
  51. C
  52. C APPEL DE TRISUP QUI CREE LES TABLEAUX CONTENUS DANS STRAV
  53. CALL TRISUP(NUMNP,PREC,NG,TRUC,TRUC1,CRIT,XMIN,YMIN,ZMIN,STRAV)
  54. IF (IIMPI.NE.0) WRITE (IOIMP,74) NUMNP,NG,TRUC,TRUC1
  55. 74 FORMAT (1X,'NUMNP=',I5,2X,'NG=',I5,2X,'TRUC=',I8,2X,'TRUC1=',I8)
  56. KELI=0
  57. TRUC3=TRUC*TRUC1
  58. ID=NUMNP
  59. IA=1
  60. IB=ITE-1
  61. CRUT=1.D0/CRIT
  62. IF(ICLE.EQ.1) THEN
  63. JG=20
  64. SEGINI MLENTI,MLENT1
  65. ENDIF
  66. C
  67. XI2=0.D0
  68. XI3=0.D0
  69. C BOUCLE SUR LES POINTS DU(DES) MAILLAGE(S)
  70. DO 6 I=IA,IB
  71. IREF=IDCP(I)*(IDIM+1)-IDIM
  72. XI1=XCOOR(IREF)
  73. NX1=INT((XI1-PREC-XMIN)*CRUT+2.D0)
  74. NX2=INT((XI1+PREC-XMIN)*CRUT+2.D0)
  75. IF (IDIM.GE.2) THEN
  76. XI2=XCOOR(IREF+1)
  77. NY1=INT((XI2-PREC-YMIN)*CRUT+1.D0)*TRUC
  78. NY2=INT((XI2+PREC-YMIN)*CRUT+1.D0)*TRUC
  79. ELSE
  80. C* XI2=0
  81. NY1=INT(1.D0-PREC*CRUT)*TRUC
  82. NY2=INT(1.D0+PREC*CRUT)*TRUC
  83. ENDIF
  84. IF (IDIM.GE.3) THEN
  85. XI3=XCOOR(IREF+2)
  86. NZ1=INT((XI3-PREC-ZMIN)*CRUT+1.D0)*TRUC3
  87. NZ2=INT((XI3+PREC-ZMIN)*CRUT+1.D0)*TRUC3
  88. ELSE
  89. C* XI3=0
  90. NZ1=INT(1.D0-PREC*CRUT)*TRUC3
  91. NZ2=INT(1.D0+PREC*CRUT)*TRUC3
  92. ENDIF
  93. IC=I+1
  94. C
  95. C BOUCLE SUR LES ZONES CREE PAR TRISUP
  96. XJ2=0.D0
  97. XJ3=0.D0
  98. DO 7 II=NZ1,NZ2,TRUC3
  99. DO 71 JJ=NY1,NY2,TRUC
  100. NTEST1=II+JJ+NX1
  101. NTEST3=II+JJ+NX2
  102. NZON1=NTEST1/NG+1
  103. NZON3=NTEST3/NG+1
  104. ND=NP1(NZON1)+1
  105. NF=NP1(NZON3+1)
  106. IF(ND.GT.NF) GO TO 71
  107. DO 72 M=ND,NF
  108. IF(NP3(M).LT.NTEST1) GO TO 72
  109. IF(NP3(M).GT.NTEST3) GO TO 71
  110. J=NP2(M)
  111. IF(J.GT.ID.OR.J.LT.IC) GO TO 72
  112. IREF=IDCP(J)*(IDIM+1)-IDIM
  113. XJ1=XCOOR(IREF)
  114. IF (IDIM.GE.2) XJ2=XCOOR(IREF+1)
  115. IF (IDIM.GE.3) XJ3=XCOOR(IREF+2)
  116. A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3)
  117. NCO2=NCO2+1
  118. IF (A.GT.PREC2) GO TO 72
  119. IF (NPI(J).LT.0.AND.ICLE.EQ.0) GOTO 72
  120. IF ((IAPOB1(I) .EQ. 2) .OR. (IAPOB1(J) .EQ. 2)) GOTO
  121. $ 72
  122. IF (((IAPOB1(I).EQ.0).AND.(IAPOB1(J).EQ.0)).OR.
  123. # ((IAPOB2(I).EQ.0).AND.(IAPOB2(J).EQ.0))) GOTO
  124. $ 72
  125. IF (IAPOB1(I).NE.0) THEN
  126. IREF1=(IDCP(I)-1)*(IDIM+1)
  127. IREF2=(IDCP(J)-1)*(IDIM+1)
  128. ELSE
  129. IREF1=(IDCP(J)-1)*(IDIM+1)
  130. IREF2=(IDCP(I)-1)*(IDIM+1)
  131. ENDIF
  132. NPI(J)=-I
  133. KELI=KELI+1
  134. C
  135. IF(ICLE.EQ.0) THEN
  136. * ON SOUDE LE PREMIER POINT SUR LE SECOND
  137. DO 10 III=1,IDIM+1
  138. XCOOR(IREF1+III)=XCOOR(IREF2+III)
  139. 10 CONTINUE
  140. C
  141. ELSEIF(ICLE.EQ.1) THEN
  142. IF(KELI.GT.JG) THEN
  143. JG=JG+20
  144. SEGADJ MLENTI,MLENT1
  145. ENDIF
  146. LECT(KELI)=IDCP(I)
  147. MLENT1.LECT(KELI)=IDCP(J)
  148. ENDIF
  149. C
  150. 72 CONTINUE
  151. 71 CONTINUE
  152. 7 CONTINUE
  153. 6 CONTINUE
  154. C
  155. IJ=0
  156. ICONT=0
  157. DO 101 I=1,NUMNP
  158. 102 IF(NPI(I).GT.0) GOTO 101
  159. IJ=-NPI(I)
  160. NPI(I)=NPI(IJ)
  161. ICONT=ICONT+1
  162. GOTO 102
  163. 101 CONTINUE
  164. C
  165. IF(ICLE.EQ.0) THEN
  166. INTERR(1) = ICONT
  167. C Erreur -293 : Nombre de noeuds eliminés %i1
  168. CALL ERREUR(-293)
  169. DO 103 I=1,XCOOR(/1)/(IDIM+1)
  170. IPC=ICPR(I)
  171. IF (IPC.EQ.0)GOTO 103
  172. ICPR(I)=NPI(IPC)
  173. 103 CONTINUE
  174. SEGSUP STRAV
  175. NUMNP=0
  176. DO 104 I=1,XCOOR(/1)/(IDIM+1)
  177. NUMNP=MAX(NUMNP,ICPR(I))
  178. 104 CONTINUE
  179. SEGINI ITLAC
  180. IF (MELEME.NE.0) CALL AJOU(ITLAC,MELEME)
  181. IF (MELEM2.NE.0) CALL AJOU(ITLAC,MELEM2)
  182. C il reste a renumeroter les coordonnes(tasser la pile des points)
  183. C et a changer les references dans tous les objets qui pointent
  184. C sur des noeuds
  185. CALL TASSP2(ITLAC,ICPR,NUMNP,ICOLAC,0)
  186. C TASSP2 nous a cree un ICOLAC dont on n'a que faire.
  187. C l'appel suivant supprime ICOLAC et ses sous-objets (donc ITLAC)
  188. CALL SUPPIL(ICOLAC,-1)
  189. C
  190. ELSEIF(ICLE.EQ.1) THEN
  191. SEGSUP STRAV
  192. IF(KELI.NE.0) THEN
  193. NBELEM=KELI
  194. NBNN=1
  195. NBREF=0
  196. NBSOUS=0
  197. SEGINI IPT3,IPT2
  198. IPT2.ITYPEL=1
  199. IPT3.ITYPEL=1
  200. DO 105 I=1,KELI
  201. IPT2.NUM(1,I)=LECT(I)
  202. IPT3.NUM(1,I)=MLENT1.LECT(I)
  203. 105 CONTINUE
  204. SEGDES IPT3,IPT2
  205. SEGSUP MLENTI,MLENT1
  206. CALL ECROBJ('MAILLAGE',IPT3)
  207. CALL ECROBJ('MAILLAGE',IPT2)
  208. C Erreur 22 : Opération malvenue. Résultat douteux
  209. IF(ICONT.NE.KELI) CALL ERREUR(22)
  210. ELSE
  211. C Erreur 26 : Tache impossible. Probablement données erronées
  212. CALL ERREUR(26)
  213. ENDIF
  214. ENDIF
  215. RETURN
  216. END
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  

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