C RACLI1 SOURCE GOUNAND 24/10/09 21:15:08 12031 SUBROUTINE RACLI1(L1,IPE, NL1) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) ************************************************************************ * * R A C L I 1 * ----------- * * FONCTION: * --------- * * CREER UNE LIGNE 'NL1' S'APPUYANT SUR LA LIGNE 'L1' * ET FINISSANT EN UN POINT E * L'ORIENTATION EST LIGNE-POINT * * MODULES UTILISES: * ----------------- * -INC CCGEOME -INC PPARAM -INC CCREEL -INC CCOPTIO -INC SMELEME * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) * ----------- * * L1 (E) LIGNE * IPE (E) POINT * (S) ATTENTION: LA DENSITE DU POINT PEUT ETRE MODIFIEE * (EN FONCTION DE LA DENSITE SUR "L1"). * NL1 (S) LIGNE DE RACCORDEMENT LIGNE-POINT * * CONSTANTES: * ----------- * PARAMETER (DEMI=0.5D0) * * VARIABLES: * ---------- * * NBNOEU = NOMBRE DE NOEUD * NBELEM = NOMBRE D'ELEMENT * INTEGER NBNOEU,NBELEM,NL,N, & ITYPLM,NBSOUS,NBREF,NBNN * * AUTEUR, DATE DE CREATION: * ------------------------- * * LIONEL VIVAN 23 NOVEMBRE 1987 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * MELEME=L1 SEGACT,MELEME NL=LISOUS(/1) IF (NL.NE.0) THEN CALL ERREUR(25) RETURN END IF IF (ILCOUR.EQ.0) THEN CALL ERREUR(16) RETURN END IF ITYPLM=KDEGRE(ILCOUR) IF (ITYPLM.EQ.0) THEN CALL ERREUR(16) RETURN END IF NBNN=NBNNE(ITYPLM) IF (NBNN.NE.2.AND.NBNN.NE.3) THEN CALL ERREUR(16) RETURN END IF NBSOUS=0 NBREF=0 NBNOEU=NUM(/1) NBELEM=NUM(/2) IP8=NUM(1,NBELEM) IP9=NUM(NBNOEU,NBELEM) * CALL EXCOO1(IPE,XE,YE,ZE,DE) CALL EXCOO1(IP8,X8,Y8,Z8,D8) CALL EXCOO1(IP9,X9,Y9,Z9,D9) * write(ioimp,*) 'XE,X8,X9=',XE,X8,X9 PS=(X9-X8)*(XE-X9)+(Y9-Y8)*(YE-Y9)+(Z9-Z8)*(ZE-Z9) DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2) D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2) * write(ioimp,*) 'PS,DE9,D98=',PS,DE9,D98 IF (PS.GE.0.D0) THEN * * POINT E HORS DE LA DROITE * IF (DE9 .GT. (D98/2.D0) ) THEN * * ON CREE UNE DROITE NL1 = L1 + DROITE(P9,PE) * IF (ABS(D9).LT.XPETIT) THEN DE=D98 ELSE DE=D9 ENDIF CALL MODPOI (XE,YE,ZE,DE,IPE) CALL ECROBJ('POINT',IPE) CALL ECROBJ('MAILLAGE',L1) CALL ECRCHA('DFIN') CALL ECRREE(DE) CALL LIGNE(1,1,DEN1,DEN2,N) IF (IERR.NE.0) RETURN CALL LIROBJ('MAILLAGE',NL1,1,IRETOU) IF (IERR.NE.0) RETURN ELSE * * ON RALLONGE LE DERNIER ELEMENT * IF (ABS(D9).LT.XPETIT) THEN DE=D98 ELSE DE=D9 ENDIF CALL MODPOI (XE,YE,ZE,DE,IPE) SEGINI,IPT1 IPT1.ITYPEL=ITYPLM NL1=IPT1 IPT1.NUM(NBNOEU,NBELEM)=IPE IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) IPT1.ICOLOR(NBELEM)=IDCOUL IF (NBNOEU.EQ.3) THEN X7=(XE+X8)*DEMI Y7=(YE+Y8)*DEMI Z7=(ZE+Z8)*DEMI D7=(DE+D8)*DEMI CALL CREPO2(X7,Y7,Z7,D7,IP7) IPT1.NUM(2,NBELEM)=IP7 END IF DO 12 I=1,(NBELEM-1) IPT1.ICOLOR(I)=IDCOUL DO 121 J=1,NBNOEU IPT1.NUM(J,I)=NUM(J,I) 121 CONTINUE 12 CONTINUE SEGDES,IPT1 END IF ELSE * * LE POINT E SE SITUE SUR LA DROITE * * RECHERCHE DE L'ELEMENT I OU SE TROUVE LE POINT E * 105 CONTINUE IF (DE9.GT.D98) THEN NBELEM=NBELEM-1 IF (NBELEM.EQ.0) THEN * Rayon du conge trop grand CALL ERREUR(399) RETURN END IF IP9=NUM(NBNOEU,NBELEM) IP8=NUM(1,NBELEM) CALL EXCOO1(IP9,X9,Y9,Z9,D9) CALL EXCOO1(IP8,X8,Y8,Z8,D8) DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2) D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2) GOTO 105 END IF IF (DE9 .LE. (D98/2.D0) ) THEN * * LE POINT E EST PROCHE DU POINT 9 * *gounand DE = D9 IF (ABS(D9).LT.XPETIT) THEN IF (ABS(D8).LT.XPETIT) THEN DE=D98-DE9 ELSE DE=D8 ENDIF ELSE DE=D9 ENDIF CALL MODPOI (XE,YE,ZE,DE,IPE) SEGINI,IPT1 IPT1.ITYPEL=ITYPLM NL1=IPT1 IPT1.NUM(NBNOEU,NBELEM)=IPE IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) IPT1.ICOLOR(NBELEM)=IDCOUL IF (NBNOEU.EQ.3) THEN X7=(X8+XE)*DEMI Y7=(Y8+YE)*DEMI Z7=(Z8+ZE)*DEMI D7=(D8+DE)*DEMI CALL CREPO2(X7,Y7,Z7,D7,IP7) IPT1.NUM(2,NBELEM)=IP7 END IF DO 22 I=1,(NBELEM-1) IPT1.ICOLOR(I)=IDCOUL DO 221 J=1,NBNOEU IPT1.NUM(J,I)=NUM(J,I) 221 CONTINUE 22 CONTINUE SEGDES,IPT1 ELSE * * LE POINT E EST PROCHE DU POINT 8 * NBELEM = NBELEM - 1 IF (NBELEM.LE.0) THEN * RAYON TROP GRAND CALL ERREUR(399) RETURN END IF * * gounand DE = D8 IF (ABS(D8).LT.XPETIT) THEN DE=D98-DE9 ELSE DE=D8 ENDIF * CALL MODPOI (XE,YE,ZE,DE,IPE) SEGINI,IPT1 IPT1.ITYPEL=ITYPLM NL1=IPT1 IPT1.NUM(NBNOEU,NBELEM)=IPE IPT1.NUM(1,NBELEM)=NUM(1,NBELEM) IPT1.ICOLOR(NBELEM)=IDCOUL IF (NBNOEU.EQ.3) THEN IP6=NUM(1,NBELEM) CALL EXCOO1(IP6,X6,Y6,Z6,D6) X7=(XE+X6)*DEMI Y7=(YE+Y6)*DEMI Z7=(ZE+Z6)*DEMI D7=(DE+D6)*DEMI CALL CREPO2(X7,Y7,Z7,D7,IP7) IPT1.NUM(2,NBELEM)=IP7 END IF DO 32 I=1,(NBELEM-1) IPT1.ICOLOR(I)=IDCOUL DO 321 J=1,NBNOEU IPT1.NUM(J,I)=NUM(J,I) 321 CONTINUE 32 CONTINUE SEGDES,IPT1 END IF END IF SEGDES,MELEME * END