Esope source files

   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
  45 :       CALL SCMAT(IFR,NBNIFR,NBIFR,
  46 :      >           IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  47 :      >           NOETRI,NBE,ITVL(ITRAV),NITMAX,
  48 :      >           ITVL(IMAT),NCC,NCCREU,iarr)
  49 :       IF( iarr.NE. 0 )GOTO 999
  50 :       NCREUX = 0
  51 :       ICREUX = IMAT
  52 :       DO 10 I=1,NBE
  53 :         IF( ITVL(I-1+IMAT).EQ.-1 )THEN
  54 :           NCREUX = NCREUX + 1
  55 :           ITVL(NCREUX-1+ICREUX) = I
  56 :         ENDIF
  57 :    10 CONTINUE
  58 : C        ==================================
  59 : C     --- 2. DESTRUCTION DES ELEMENTS CREUX ----
  60 : C        ==================================
  61 : C
  62 : C     --- 2.1 DECONNECTION DES NOEUDS NOETRI(IP)=0 ----
  63 :       NOEMAX = 0
  64 : C     --- BUG_12 CORRIGE LE 20.11.95 O.STAB ---------
  65 :       DO 25 I=1,NCREUX
  66 :         DO 20 J=1,NBNMAX
  67 :            IP = ITRNOE((ITVL(ICREUX-1+I)-1)*NBNMAX+J)
  68 :            IF(IP.NE.0)NOETRI(IP) = 0
  69 :    20   CONTINUE 
  70 :    25 CONTINUE   
  71 : C     --- 2.2 COMPRESSION AU DEBUT ---
  71 :       CALL ENSTRI(ITVL(ICREUX),NCREUX)
  71 :       CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  72 :      >            NOEMAX,NBE,ITVL(ICREUX),NCREUX,iarr)
  73 :       IF(iarr .NE. 0)THEN
  73 :          CALL DSERRE(1,iarr,'NUCOMP','COMPRESSION EL')
  74 :          GOTO 999
  75 :       ENDIF
  76 : C
  77 : C     --- POUR LE DEBUG ---
  77 : C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  78 : C     >              NBE,NOEMAX,ITRACE,iarr) 
  79 : C      IF( iarr .NE. 0 )THEN
  79 : C        CALL DSERRE(1,iarr,'SCULPT',' NUCOMP')        
  80 : C        GO TO 999
  81 : C      ENDIF
  82 : C     --- 2.3 DESTRUCTION ---
  83 :       NBFNOE  = 0
  84 :       NBSOMP  = 0
  85 :       ISOMP   = IMAT
  86 :       DO 30 I=1,NCREUX
  86 :         CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
  87 :      >          NBFNOE,I,NBCMAX,ITVL(ISOMP+NBSOMP),NBSOMP,iarr)
  88 :         IF( iarr .NE. 0  )GOTO 999
  89 :    30 CONTINUE
  90 : C     --- BUG_12 CORRIGE LE 20.11.95 O.STAB ---------
  91 :       DO 40 I=1,MIN(NCREUX,NBE-NCREUX)
  91 :         CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  92 :      >                NOEMAX,NBE,I,(NBE+1-I),iarr)
  93 :         IF( iarr .NE. 0  )GOTO 999
  94 :    40 CONTINUE
  95 :       NBE = NBE - NCREUX
  96 : C     --- POUR LE DEBUG ---
  96 : C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  97 : C     >              NBE-I,NOEMAX,ITRACE,iarr) 
  98 : C      IF( iarr .NE. 0 )THEN
  98 : C        CALL DSERRE(1,iarr,'SCULPT',' NUCOMP')        
  99 : C        GO TO 999
 100 : C      ENDIF
 101 : C
 102 :       IF( NBSOMP.NE.0 )THEN
 103 :        iarr = -1
 103 :        CALL DSERRE(1,iarr,'SCULPT','SOMMETS PERDUS')
 104 : C       PRINT *, (ITVL(ISOMP),I=1,NBSOMP)
 105 :        GO TO 999
 106 :       ENDIF
 107 : C        ==================================
 108 : C     --- MISE A JOUR DE NOETRI : O(3*NBE) ---
 109 : C        ==================================
 110 :       DO 70 I=1,NBE
 111 :         DO 60 J=1,NBNMAX
 112 :            IP = ITRNOE((I-1)*NBNMAX+J)
 113 :            IF(IP.NE.0)NOETRI(IP) = I
 114 :    60   CONTINUE    
 115 :    70 CONTINUE    
 116 : C      
 117 : C
 118 :   999 END      
 119 :  
 120 :  
 121 :