1 : C NUPERM SOURCE CHAT 06/03/29 21:28:41 5360 2 : C 3 : 4 : 5 : 6 : C ***************************************************************** 7 : C MODULE : ST (STRUCTURE DES DONNEES) 8 : C FICHIER : ST_NUMERO.F 9 : C OBJET : RENUMEROTE UN MAILLAGE 2D OU 3D 10 : C FONCT. : 11 : C NUPERM : PERMUTE 2 ELEMENTS D'UN MAILLAGE 12 : C NURENU : RENUMEROTE LES ELEMENTS D'UN MAILLAGE 13 : C NUCOMP : RENUMEROTE LES ELEMENTS D'UN MAILLAGE POUR LES 14 : C COMPACTER EN DEBUT : DE 1 A "NBNUM" 15 : C 16 : C AUTEUR : O. STAB 17 : C DATE : 03.95 18 : C TESTS : O.STAB 03.95 19 : C MODIFICATIONS : 20 : C AUTEUR, DATE, OBJET : 21 : C 22 : C 23 : C ***************************************************************** 24 : C 25 : SUBROUTINE NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 26 : > NOEMAX,NBE,IT1,IT2,iarr) 27 : C ***************************************************************** 28 : C OBJET : PERMUTE 2 ELEMENTS D'UN MAILLAGE 29 : C EN ENTREE: 30 : C IDE : (1..3) DIMENSION DES ELEMENTS (POURRA SERVIR) 31 : C ITRNOE: LES NOEUDS DES ELEMENTS 32 : C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS 33 : C ITRTRI: LES VOISINS DES ELEMENTS 34 : C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS 35 : C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE 36 : C NBE : NOMBRE D'ELEMENTS DU MAILLAGE 37 : C IT1,IT2: LES 2 ELEMENTS A PERMUTER 38 : C EN SORTIE: 39 : C ITRNOE: MIS A JOUR 40 : C ITRTRI: MIS A JOUR 41 : C NOETRI : MIS A JOUR 42 : C iarr : CODE D'ERREUR 0 => OK 43 : C -1 => DONNEES INCOHERENTES 44 : C CONDITION D'APPLICATION : TOUT MAILLAGE 45 : C ***************************************************************** 46 : IMPLICIT INTEGER(I-N) 47 : INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE 48 : INTEGER NOEMAX,IT1, IT2, iarr 49 : C 50 : INTEGER I,J,K,ITRTR2(6),ITRNO2(8),IT(3),ITR,IFRINT 51 : INTEGER NNT,NTRTRI(2*6,3) 52 : C 53 : iarr = 0 54 : IF( IT1 .EQ. IT2 )GO TO 999 55 : IF((IT1.LT.1).OR.(IT1.GT.NBE).OR. 56 : > (IT2.LT.1).OR.(IT2.GT.NBE))THEN 57 : iarr = -1 57 : CALL DSERRE(1,iarr,' NUPERM','NUMERO HORS INTERVAL') 58 : GO TO 999 59 : ENDIF 60 : C ---- MISE A JOUR DES REFERENC.OR.ES A IT1 ET IT2 --- 61 : IT(1) = IT1 62 : IT(2) = IT2 63 : IT(3) = IT1 64 : NNT = 0 65 : DO 10 K=1,2 66 : IF( NOEMAX .GT. 0 )THEN 67 : C -- MISE A JOUR DES NOEUDS FAISANT REFERENCE A IT1,IT2 --- 68 : DO 20 I=1,NBNMAX 69 : IF( NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) .EQ. IT(K) ) 70 : > NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) = IT(K+1) 71 : 20 CONTINUE 72 : ENDIF 73 : C ---- MISE A JOUR DES ELEMENTS VOISINS DE IT1,IT2 --- 74 : DO 30 I=1,NBCMAX 75 : ITR = ITRTRI((IT(K)-1)*NBCMAX+I) 76 : IF((ITR.NE.0).AND.(ITR.NE.IT(K+1)) 77 : > .AND.(ITR.NE.-IT(K+1)))THEN 78 : IFRINT = 1 79 : IF( ITR .LT. 0 )THEN 80 : IFRINT = -1 81 : ITR = - ITR 82 : ENDIF 83 : DO 40 J=1,NBCMAX 84 : IF( (ITRTRI((ITR-1)*NBCMAX+J).EQ.IT(K)) .OR. 85 : > (ITRTRI((ITR-1)*NBCMAX+J).EQ.-IT(K)) )THEN 86 : NNT = NNT + 1 87 : NTRTRI(NNT,1) = ITR 88 : NTRTRI(NNT,2) = J 89 : NTRTRI(NNT,3) = IFRINT * IT(K+1) 90 : C ITRTRI((ITR-1)*NBCMAX+J) = IFRINT * IT(K+1) 91 : GO TO 30 92 : ENDIF 93 : 40 CONTINUE 94 : C --- IL Y A UN BUG DANS LA STRUCTURE --- 95 : iarr = -1 95 : CALL DSERRE(1,iarr,' NUPERM',' STRUCTURE MAILLAGE') 96 : GO TO 999 97 : ENDIF 98 : 30 CONTINUE 99 : 10 CONTINUE 100 : C ------------------ MIS AJOUR DES VOISINS DE IT1,IT2 --- 101 : DO 45 I=1,NNT 102 : ITRTRI((NTRTRI(I,1)-1)*NBCMAX+NTRTRI(I,2))=NTRTRI(I,3) 103 : 45 CONTINUE 104 : C ------------------ SAUVEGARDE IT2 --- 105 : DO 50 I=1,NBCMAX 106 : IF( ITRTRI((IT2-1)*NBCMAX+I) .EQ. IT1 )THEN 107 : ITRTR2(I)=IT2 108 : ELSE IF( ITRTRI((IT2-1)*NBCMAX+I).EQ.-IT1)THEN 109 : ITRTR2(I)=-IT2 110 : ELSE 111 : ITRTR2(I)=ITRTRI((IT2-1)*NBCMAX+I) 112 : ENDIF 113 : 50 CONTINUE 114 : DO 60 I=1,NBNMAX 115 : ITRNO2(I)=ITRNOE((IT2-1)*NBNMAX+I) 116 : 60 CONTINUE 117 : C ---------- TRANSFERT IT1 -> IT2 ---------- 118 : DO 70 I=1,NBCMAX 119 : IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. IT2 )THEN 120 : ITRTRI((IT2-1)*NBCMAX+I)=IT1 121 : ELSE IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. -IT2 )THEN 122 : ITRTRI((IT2-1)*NBCMAX+I)=-IT1 123 : ELSE 124 : ITRTRI((IT2-1)*NBCMAX+I)=ITRTRI((IT1-1)*NBCMAX+I) 125 : ENDIF 126 : 70 CONTINUE 127 : DO 80 I=1,NBNMAX 128 : ITRNOE((IT2-1)*NBNMAX+I)=ITRNOE((IT1-1)*NBNMAX+I) 129 : 80 CONTINUE 130 : C ---------- TRANSFERT IT2 -> IT1 ---------- 131 : DO 90 I=1,NBCMAX 132 : ITRTRI((IT1-1)*NBCMAX+I)=ITRTR2(I) 133 : 90 CONTINUE 134 : DO 100 I=1,NBNMAX 135 : ITRNOE((IT1-1)*NBNMAX+I)=ITRNO2(I) 136 : 100 CONTINUE 137 : C ------------------ 138 : 999 END 139 : 140 : 141 :
© Cast3M 2003 - All rights reserved.
Disclaimer