Sources Esope | Cast3M

nuperm
C NUPERM    SOURCE    CHAT      06/03/29    21:28:41     5360
C
 
 
 
C     *****************************************************************
C     MODULE  : ST (STRUCTURE DES DONNEES)
C     FICHIER : ST_NUMERO.F
C     OBJET   : RENUMEROTE UN MAILLAGE 2D OU 3D
C     FONCT.  :
C          NUPERM    : PERMUTE 2 ELEMENTS D'UN MAILLAGE
C          NURENU     : RENUMEROTE LES ELEMENTS D'UN MAILLAGE
C          NUCOMP  : RENUMEROTE LES ELEMENTS D'UN MAILLAGE POUR LES
C                        COMPACTER EN DEBUT : DE 1 A "NBNUM"
C
C     AUTEUR  : O. STAB
C     DATE    : 03.95
C     TESTS   : O.STAB 03.95
C     MODIFICATIONS :
C      AUTEUR, DATE, OBJET :
C
C
C     *****************************************************************
C
      SUBROUTINE NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
     >                   NOEMAX,NBE,IT1,IT2,iarr)
C     *****************************************************************
C     OBJET : PERMUTE 2 ELEMENTS D'UN MAILLAGE
C     EN ENTREE:
C      IDE    :  (1..3) DIMENSION DES ELEMENTS (POURRA SERVIR)
C      ITRNOE:  LES NOEUDS DES ELEMENTS
C      NBNMAX :  (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS
C      ITRTRI:  LES VOISINS DES ELEMENTS
C      NBCMAX :  (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS
C      NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE
C      NBE    :  NOMBRE D'ELEMENTS DU MAILLAGE
C      IT1,IT2:  LES 2 ELEMENTS A PERMUTER
C     EN SORTIE:
C       ITRNOE: MIS A JOUR
C       ITRTRI: MIS A JOUR
C       NOETRI : MIS A JOUR
C         iarr : CODE D'ERREUR 0 => OK
C               -1 => DONNEES INCOHERENTES
C     CONDITION D'APPLICATION : TOUT MAILLAGE
C     *****************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER    IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE
      INTEGER    NOEMAX,IT1, IT2, iarr
C
      INTEGER I,J,K,ITRTR2(6),ITRNO2(8),IT(3),ITR,IFRINT
      INTEGER NNT,NTRTRI(2*6,3)
C
      iarr = 0
      IF( IT1 .EQ. IT2 )GO TO 999
      IF((IT1.LT.1).OR.(IT1.GT.NBE).OR.
     >   (IT2.LT.1).OR.(IT2.GT.NBE))THEN
         iarr = -1
         CALL DSERRE(1,iarr,' NUPERM','NUMERO HORS INTERVAL')
         GO TO 999
      ENDIF
C     ---- MISE A JOUR DES REFERENC.OR.ES A IT1 ET IT2 ---
      IT(1) = IT1
      IT(2) = IT2
      IT(3) = IT1
      NNT = 0
      DO 10 K=1,2
        IF( NOEMAX .GT. 0 )THEN
C       -- MISE A JOUR DES NOEUDS FAISANT REFERENCE A IT1,IT2 ---
          DO 20 I=1,NBNMAX
            IF( NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) .EQ. IT(K) )
     >          NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) = IT(K+1)
   20     CONTINUE
        ENDIF
C     ---- MISE A JOUR DES ELEMENTS VOISINS DE IT1,IT2 ---
        DO 30 I=1,NBCMAX
          ITR = ITRTRI((IT(K)-1)*NBCMAX+I)
          IF((ITR.NE.0).AND.(ITR.NE.IT(K+1))
     >        .AND.(ITR.NE.-IT(K+1)))THEN
            IFRINT = 1
            IF( ITR .LT. 0 )THEN
              IFRINT = -1
              ITR = - ITR
            ENDIF
            DO 40 J=1,NBCMAX
             IF( (ITRTRI((ITR-1)*NBCMAX+J).EQ.IT(K)) .OR.
     >           (ITRTRI((ITR-1)*NBCMAX+J).EQ.-IT(K)) )THEN
                  NNT = NNT + 1
                  NTRTRI(NNT,1) = ITR
                  NTRTRI(NNT,2) = J
                  NTRTRI(NNT,3) = IFRINT * IT(K+1)
C                  ITRTRI((ITR-1)*NBCMAX+J) = IFRINT * IT(K+1)
             GO TO 30
             ENDIF
   40       CONTINUE
C         --- IL Y A UN BUG DANS LA STRUCTURE ---
          iarr = -1
          CALL DSERRE(1,iarr,' NUPERM',' STRUCTURE MAILLAGE')
          GO TO 999
          ENDIF
   30   CONTINUE
   10 CONTINUE
C     ------------------ MIS AJOUR DES VOISINS DE IT1,IT2 ---
      DO 45 I=1,NNT
       ITRTRI((NTRTRI(I,1)-1)*NBCMAX+NTRTRI(I,2))=NTRTRI(I,3)
   45 CONTINUE
C     ------------------ SAUVEGARDE IT2 ---
      DO 50 I=1,NBCMAX
        IF( ITRTRI((IT2-1)*NBCMAX+I) .EQ. IT1 )THEN
          ITRTR2(I)=IT2
        ELSE IF( ITRTRI((IT2-1)*NBCMAX+I).EQ.-IT1)THEN
          ITRTR2(I)=-IT2
        ELSE
          ITRTR2(I)=ITRTRI((IT2-1)*NBCMAX+I)
        ENDIF
   50 CONTINUE
      DO 60 I=1,NBNMAX
        ITRNO2(I)=ITRNOE((IT2-1)*NBNMAX+I)
   60 CONTINUE
C     ---------- TRANSFERT IT1 -> IT2 ----------
      DO 70 I=1,NBCMAX
        IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. IT2 )THEN
          ITRTRI((IT2-1)*NBCMAX+I)=IT1
        ELSE IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. -IT2 )THEN
          ITRTRI((IT2-1)*NBCMAX+I)=-IT1
        ELSE
          ITRTRI((IT2-1)*NBCMAX+I)=ITRTRI((IT1-1)*NBCMAX+I)
        ENDIF
   70 CONTINUE
      DO 80 I=1,NBNMAX
        ITRNOE((IT2-1)*NBNMAX+I)=ITRNOE((IT1-1)*NBNMAX+I)
   80 CONTINUE
C     ---------- TRANSFERT IT2 -> IT1 ----------
      DO 90 I=1,NBCMAX
        ITRTRI((IT1-1)*NBCMAX+I)=ITRTR2(I)
   90 CONTINUE
      DO 100 I=1,NBNMAX
        ITRNOE((IT1-1)*NBNMAX+I)=ITRNO2(I)
  100 CONTINUE
C     ------------------
  999 END