Télécharger la plaquette Cast3M


fr en

Télécharger sculpt.eso

Retour à la liste

Numérotation des lignes : 

sculpt

  1. C SCULPT    SOURCE    CHAT      06/03/29    21:33:14     5360
  2.       SUBROUTINE SCULPT(IFR,NBNIFR,NBIFR,
  3.      >                     IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  4.      >                     NOETRI,NBE,ITVL,IMAX,NCC,iarr)
  5. C     **********************************************************************
  6. C     OBJET : SCULPT DETERMINE LE PLEIN ET LE VIDE A PARTIR DE FRONTIERES
  7. C             DONNEES
  8. C     EN ENTREE  :
  9. C       IFR      : LES ELEMENTS DES FRONTIERES
  10. C       NBIFR    : NOMBRE D'ELEMENTS FRONTIERE
  11. C
  12. C       ITVL : TABLEAU DE TRAVAIL = 2 * NBE + PILE (APPEL TMA1CC)
  13. C       IMAX      : TAILLE DU TABLEAU DE TRAVAIL
  14. C
  15. C     EN SORTIE  : LA TRIANGULATION MISE A JOUR
  16. C       ITRNOE,NBNMAX : NOEUDS DES ELEMENTS    "   "   "  "
  17. C       ITRTRI,NBCMAX : ELEMENTS VOISINS
  18. C       NOETRI         : UN DES ELEMENTS INCIDENT A UN POINT
  19. C       NCC            : NOMBRE DE COMPOSANTES CONNEXES
  20. C       iarr           : CODE D'ERREUR
  21. C                        -1 UN ELEMENT FRONTIERE DE IFR N'EXISTE PAS
  22. C                        -2 ITVL OU RTRAVAIL TROP PETIT
  23. C     **********************************************************************
  24.       IMPLICIT INTEGER(I-N)
  25.       INTEGER    IFR(*),NBIFR,NBNIFR,IDE
  26.       INTEGER    ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
  27.       INTEGER    NOETRI(*),NBE,ITVL(*),IMAX,NCC,iarr
  28. C
  29.       INTEGER IMAT,ITRAV,NITMAX
  30.       INTEGER ICREUX,NCREUX,NCCREU
  31.       INTEGER NBSOMP,ISOMP,NBFNOE,I,J,IP,NOEMAX
  32. C        =======================================
  33. C     --- 1. AFFECTATION DES PLEIN ET DES CREUX ----
  34. C        =======================================
  35.       NCC = 1
  36.       iarr = 0
  37.       IF( NBIFR.EQ. 0)GOTO 999
  38.       IMAT  = 1
  39.       ITRAV = IMAT + NBE
  40.       NITMAX = IMAX - ITRAV + 1
  41.       IF( NITMAX.LT. (2*NBE))THEN
  42.         iarr = -2
  43.         GOTO 999
  44.       ENDIF
  45. C
  46.       CALL SCMAT(IFR,NBNIFR,NBIFR,
  47.      >           IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  48.      >           NOETRI,NBE,ITVL(ITRAV),NITMAX,
  49.      >           ITVL(IMAT),NCC,NCCREU,iarr)
  50.       IF( iarr.NE. 0 )GOTO 999
  51.       NCREUX = 0
  52.       ICREUX = IMAT
  53.       DO 10 I=1,NBE
  54.         IF( ITVL(I-1+IMAT).EQ.-1 )THEN
  55.           NCREUX = NCREUX + 1
  56.           ITVL(NCREUX-1+ICREUX) = I
  57.         ENDIF
  58.    10 CONTINUE
  59. C        ==================================
  60. C     --- 2. DESTRUCTION DES ELEMENTS CREUX ----
  61. C        ==================================
  62. C
  63. C     --- 2.1 DECONNECTION DES NOEUDS NOETRI(IP)=0 ----
  64.       NOEMAX = 0
  65. C     --- BUG_12 CORRIGE LE 20.11.95 O.STAB ---------
  66.       DO 25 I=1,NCREUX
  67.         DO 20 J=1,NBNMAX
  68.            IP = ITRNOE((ITVL(ICREUX-1+I)-1)*NBNMAX+J)
  69.            IF(IP.NE.0)NOETRI(IP) = 0
  70.    20   CONTINUE
  71.    25 CONTINUE
  72. C     --- 2.2 COMPRESSION AU DEBUT ---
  73.       CALL ENSTRI(ITVL(ICREUX),NCREUX)
  74.       CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  75.      >            NOEMAX,NBE,ITVL(ICREUX),NCREUX,iarr)
  76.       IF(iarr .NE. 0)THEN
  77.          CALL DSERRE(1,iarr,'NUCOMP','COMPRESSION EL')
  78.          GOTO 999
  79.       ENDIF
  80. C
  81. C     --- POUR LE DEBUG ---
  82. C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  83. C     >              NBE,NOEMAX,ITRACE,iarr)
  84. C      IF( iarr .NE. 0 )THEN
  85. C        CALL DSERRE(1,iarr,'SCULPT',' NUCOMP')
  86. C        GO TO 999
  87. C      ENDIF
  88. C     --- 2.3 DESTRUCTION ---
  89.       NBFNOE  = 0
  90.       NBSOMP  = 0
  91.       ISOMP   = IMAT
  92.       DO 30 I=1,NCREUX
  93.         CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
  94.      >          NBFNOE,I,NBCMAX,ITVL(ISOMP+NBSOMP),NBSOMP,iarr)
  95.         IF( iarr .NE. 0  )GOTO 999
  96.    30 CONTINUE
  97. C     --- BUG_12 CORRIGE LE 20.11.95 O.STAB ---------
  98.       DO 40 I=1,MIN(NCREUX,NBE-NCREUX)
  99.         CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  100.      >                NOEMAX,NBE,I,(NBE+1-I),iarr)
  101.         IF( iarr .NE. 0  )GOTO 999
  102.    40 CONTINUE
  103.       NBE = NBE - NCREUX
  104. C     --- POUR LE DEBUG ---
  105. C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  106. C     >              NBE-I,NOEMAX,ITRACE,iarr)
  107. C      IF( iarr .NE. 0 )THEN
  108. C        CALL DSERRE(1,iarr,'SCULPT',' NUCOMP')
  109. C        GO TO 999
  110. C      ENDIF
  111. C
  112.       IF( NBSOMP.NE.0 )THEN
  113.        iarr = -1
  114.        CALL DSERRE(1,iarr,'SCULPT','SOMMETS PERDUS')
  115. C       PRINT *, (ITVL(ISOMP),I=1,NBSOMP)
  116.        GO TO 999
  117.       ENDIF
  118. C        ==================================
  119. C     --- MISE A JOUR DE NOETRI : O(3*NBE) ---
  120. C        ==================================
  121.       DO 70 I=1,NBE
  122.         DO 60 J=1,NBNMAX
  123.            IP = ITRNOE((I-1)*NBNMAX+J)
  124.            IF(IP.NE.0)NOETRI(IP) = I
  125.    60   CONTINUE
  126.    70 CONTINUE
  127. C
  128. C
  129.   999 END
  130.  
  131.  
  132.  
  133.  

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