1 : C RACLI1 SOURCE CHAT 07/10/29 21:27:16 5940 2 : SUBROUTINE RACLI1(L1,IPE, NL1) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * R A C L I 1 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREER UNE LIGNE 'NL1' S'APPUYANT SUR LA LIGNE 'L1' 14 : * ET FINISSANT EN UN POINT E 15 : * L'ORIENTATION EST LIGNE-POINT 16 : * 17 : * MODULES UTILISES: 18 : * ----------------- 19 : * 20 : -INC CCGEOME 21 : -INC CCOPTIO 22 : -INC SMELEME 23 : * 24 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 25 : * ----------- 26 : * 27 : * L1 (E) LIGNE 28 : * IPE (E) POINT 29 : * (S) ATTENTION: LA DENSITE DU POINT PEUT ETRE MODIFIEE 30 : * (EN FONCTION DE LA DENSITE SUR "L1"). 31 : * NL1 (S) LIGNE DE RACCORDEMENT LIGNE-POINT 32 : * 33 : * CONSTANTES: 34 : * ----------- 35 : * 36 : PARAMETER (DEMI=0.5D0) 37 : * 38 : * VARIABLES: 39 : * ---------- 40 : * 41 : * NBNOEU = NOMBRE DE NOEUD 42 : * NBELEM = NOMBRE D'ELEMENT 43 : * 44 : INTEGER NBNOEU,NBELEM,NL,N, 45 : & ITYPLM,NBSOUS,NBREF,NBNN 46 : * 47 : * AUTEUR, DATE DE CREATION: 48 : * ------------------------- 49 : * 50 : * LIONEL VIVAN 23 NOVEMBRE 1987 51 : * 52 : * LANGAGE: 53 : * -------- 54 : * 55 : * ESOPE + FORTRAN77 56 : * 57 : ************************************************************************ 58 : * 59 : MELEME=L1 60 : SEGACT,MELEME 61 : NL=LISOUS(/1) 62 : IF (NL.NE.0) THEN 62 : CALL ERREUR(25) 63 : RETURN 64 : END IF 65 : IF (ILCOUR.EQ.0) THEN 65 : CALL ERREUR(16) 66 : RETURN 67 : END IF 68 : ITYPLM=KDEGRE(ILCOUR) 69 : IF (ITYPLM.EQ.0) THEN 69 : CALL ERREUR(16) 70 : RETURN 71 : END IF 72 : NBNN=NBNNE(ITYPLM) 73 : IF (NBNN.NE.2.AND.NBNN.NE.3) THEN 73 : CALL ERREUR(16) 74 : RETURN 75 : END IF 76 : NBSOUS=0 77 : NBREF=0 78 : NBNOEU=NUM(/1) 79 : NBELEM=NUM(/2) 80 : IP8=NUM(1,NBELEM) 81 : IP9=NUM(NBNOEU,NBELEM) 82 : * 82 : CALL EXCOO1(IPE,XE,YE,ZE,DE) 82 : CALL EXCOO1(IP8,X8,Y8,Z8,D8) 82 : CALL EXCOO1(IP9,X9,Y9,Z9,D9) 83 : PS=(X9-X8)*(XE-X9)+(Y9-Y8)*(YE-Y9)+(Z9-Z8)*(ZE-Z9) 84 : * 85 : DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2) 86 : D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2) 87 : IF (PS.GE.0.) THEN 88 : * 89 : * POINT E HORS DE LA DROITE 90 : * 91 : IF (DE9 .GT. (D98/2.D0) ) THEN 92 : * 93 : * ON CREE UNE DROITE NL1 = L1 + DROITE(P9,PE) 94 : * 94 : CALL ECROBJ('POINT',IPE) 94 : CALL ECROBJ('MAILLAGE',L1) 94 : CALL LIGNE(1,1,DEN1,DEN2,N) 95 : IF (IERR.NE.0) RETURN 95 : CALL LIROBJ('MAILLAGE',NL1,1,IRETOU) 96 : IF (IERR.NE.0) RETURN 97 : ELSE 98 : * 99 : * ON RALLONGE LE DERNIER ELEMENT 100 : * 101 : DE = D9 101 : CALL MODPOI (XE,YE,ZE,DE,IPE) 102 : SEGINI,IPT1 103 : IPT1.ITYPEL=ITYPLM 104 : NL1=IPT1 105 : IPT1.NUM(NBNOEU,NBELEM)=IPE 106 : IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) 107 : IPT1.ICOLOR(NBELEM)=IDCOUL 108 : IF (NBNOEU.EQ.3) THEN 109 : X7=(XE+X8)*DEMI 110 : Y7=(YE+Y8)*DEMI 111 : Z7=(ZE+Z8)*DEMI 112 : D7=(DE+D8)*DEMI 112 : CALL CREPO2(X7,Y7,Z7,D7,IP7) 113 : IPT1.NUM(2,NBELEM)=IP7 114 : END IF 115 : DO 12 I=1,(NBELEM-1) 116 : IPT1.ICOLOR(I)=IDCOUL 117 : DO 12 J=1,NBNOEU 118 : IPT1.NUM(J,I)=NUM(J,I) 119 : 12 CONTINUE 120 : * END DO 121 : * END DO 122 : SEGDES,IPT1 123 : END IF 124 : ELSE 125 : * 126 : * LE POINT E SE SITUE SUR LA DROITE 127 : * 128 : * RECHERCHE DE L'ELEMENT I OU SE TROUVE LE POINT E 129 : * 130 : 105 IF (DE9.GT.D98) THEN 131 : NBELEM=NBELEM-1 132 : IF (NBELEM.EQ.0) THEN 132 : CALL ERREUR(399) 133 : RETURN 134 : END IF 135 : IP9=NUM(NBNOEU,NBELEM) 136 : IP8=NUM(1,NBELEM) 136 : CALL EXCOO1(IP9,X9,Y9,Z9,D9) 136 : CALL EXCOO1(IP8,X8,Y8,Z8,D8) 137 : DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2) 138 : D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2) 139 : GOTO 105 140 : END IF 141 : IF (DE9 .LE. (D98/2.D0) ) THEN 142 : * 143 : * LE POINT E EST PROCHE DU POINT 9 144 : * 145 : DE = D9 145 : CALL MODPOI (XE,YE,ZE,DE,IPE) 146 : SEGINI,IPT1 147 : IPT1.ITYPEL=ITYPLM 148 : NL1=IPT1 149 : IPT1.NUM(NBNOEU,NBELEM)=IPE 150 : IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) 151 : IPT1.ICOLOR(NBELEM)=IDCOUL 152 : IF (NBNOEU.EQ.3) THEN 153 : X7=(X8+XE)*DEMI 154 : Y7=(Y8+YE)*DEMI 155 : Z7=(Z8+ZE)*DEMI 156 : D7=(D8+DE)*DEMI 156 : CALL CREPO2(X7,Y7,Z7,D7,IP7) 157 : IPT1.NUM(2,NBELEM)=IP7 158 : END IF 159 : DO 22 I=1,(NBELEM-1) 160 : IPT1.ICOLOR(I)=IDCOUL 161 : DO 22 J=1,NBNOEU 162 : IPT1.NUM(J,I)=NUM(J,I) 163 : 22 CONTINUE 164 : * END DO 165 : * END DO 166 : SEGDES,IPT1 167 : ELSE 168 : * 169 : * LE POINT E EST PROCHE DU POINT 8 170 : * 171 : NBELEM = NBELEM - 1 172 : IF (NBELEM.LE.0) THEN 173 : * RAYON TROP GRAND 173 : CALL ERREUR(399) 174 : RETURN 175 : END IF 176 : * 177 : DE = D8 177 : CALL MODPOI (XE,YE,ZE,DE,IPE) 178 : SEGINI,IPT1 179 : IPT1.ITYPEL=ITYPLM 180 : NL1=IPT1 181 : IPT1.NUM(NBNOEU,NBELEM)=IPE 182 : IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) 183 : IPT1.ICOLOR(NBELEM)=IDCOUL 184 : IF (NBNOEU.EQ.3) THEN 185 : IP6=NUM(1,NBELEM) 185 : CALL EXCOO1(IP6,X6,Y6,Z6,D6) 186 : X7=(XE+X6)*DEMI 187 : Y7=(YE+Y6)*DEMI 188 : Z7=(ZE+Z6)*DEMI 189 : D7=(DE+D6)*DEMI 189 : CALL CREPO2(X7,Y7,Z7,D7,IP7) 190 : IPT1.NUM(2,NBELEM)=IP7 191 : END IF 192 : DO 32 I=1,(NBELEM-1) 193 : IPT1.ICOLOR(I)=IDCOUL 194 : DO 32 J=1,NBNOEU 195 : IPT1.NUM(J,I)=NUM(J,I) 196 : 32 CONTINUE 197 : * END DO 198 : * END DO 199 : SEGDES,IPT1 200 : END IF 201 : END IF 202 : SEGDES,MELEME 203 : * 204 : END 205 : 206 : 207 : 208 : 209 : 210 : 211 :
© Cast3M 2003 - All rights reserved.
Disclaimer