Télécharger la plaquette Cast3M


fr en

Télécharger elimin.eso

Retour à la liste

Numérotation des lignes : 

elimin

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

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