C PRTRAN SOURCE SP204843 24/03/15 21:15:08 11871 C PREPARATION DE LA TRANSLATION ET DE LA ROTATION D'UNE LIGNE C C MODIFICATION NOVEMBRE 1984 INTRODUCTION DE LA DEGENERESCENCE DANS C LE CAS DE ROTATION DONT L'AXE PASSE PAR UN (OU DEUX) POINT DE C LA LIGNE (MODIFICATION NON TERMINE) C SUBROUTINE PRTRAN(IOPTG) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION XCO(4) DIMENSION XROT1(3),XROT2(3) CHARACTER*4 MCLE(2) -INC CCREEL -INC PPARAM -INC CCOPTIO logical ltelq SEGMENT TABPAR REAL*8 TABPA1(NCOUCH) ENDSEGMENT -INC CCGEOME -INC SMCOORD -INC SMELEME SEGMENT ICPR INTEGER ICPR1(2,NBELEC) ENDSEGMENT SEGMENT ICPP INTEGER ICPP1(nbpts) ENDSEGMENT COMMON/CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, # ZVEC,ANGLE,ICLE,XP1,YP1,ZP1 DATA MCLE/'DINI','DFIN'/ XDIS=0.D0 YDIS=0.D0 ZDIS=0.D0 IMPOI=0 IMPOF=0 C Y A T IL UN DECOUPAGE IMPOSE INBR=0 CALL MESLIR(-236) CALL LIRENT(INBR,0,IRETOU) * IF (IRETOU.EQ.1) INBR=MAX(1,INBR) IF (IDIM.EQ.3.AND.IOPTG.EQ.2) IOPTG=3 IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16) C CAS DE LA ROTATION DONNEE OBLIGATOIRE L'ANGLE IF (IOPTG.EQ.1) GOTO 1 IOB=0 IF (INBR.EQ.0) IOB=1 CALL MESLIR(-235) CALL LIRREE(XXX,IOB,IRETOU) FLOT=XXX IF (IERR.NE.0) RETURN IF (IRETOU.EQ.1) GOTO 2 IF (INBR.NE.0) FLOT=INBR INBR=0 2 CONTINUE ANGLE=FLOT*XPI/180.D0 IF (IERR.NE.0) RETURN 1 CONTINUE C Y A T-IL DES DENSITES IMPOSEES 3 CONTINUE CALL MESLIR(-234) CALL LIRMOT(MCLE,2,IRETOU,0) IF (IRETOU.EQ.1) THEN CALL MESLIR(-170) CALL LIRREE(XXX,1,IRETOU) DEN1D=XXX IF (IERR.NE.0) RETURN IMPOI=1 GOTO 3 ELSEIF (IRETOU.EQ.2) THEN CALL MESLIR(-169) CALL LIRREE(XXX,1,IRETOU) DEN2D=XXX IF (IERR.NE.0) RETURN IMPOF=1 GOTO 3 ENDIF CALL MESLIR(-131) CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) IF (IERR.NE.0) RETURN CALL EXTRLI(IPT1,3,IRET,-1) IF (IERR.NE.0) RETURN IFUSE=0 IF (IPT1.NE.IRET) IFUSE=IPT1 IPT1=IRET IF (IOPTG.EQ.1) CALL MESLIR(-233) IF (IOPTG.EQ.2) CALL MESLIR(-232) CALL LIROBJ('POINT ',IP1,1,IRETOU) IF (IOPTG.EQ.3) THEN CALL MESLIR(-231) CALL LIROBJ('POINT ',IP2,1,IRETOU) IF (IERR.NE.0) RETURN ENDIF 12 SEGACT IPT1 11 SEGACT MCOORD*mod NBNN=IPT1.NUM(/1) * VERIFIER TYPE D'ELEMENT ACCEPTABLE IF (IPT1.ITYPEL.NE.2.AND.IPT1.ITYPEL.NE.3) CALL ERREUR(16) IF (IERR.NE.0) RETURN NBELEM=IPT1.NUM(/2) XG=0.D0 YG=0.D0 ZG=0.D0 DEN1=0.D0 IBOUCL=0 IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1 DO 17 I=1,NBNN DO 171 J=1,NBELEM IREF=IPT1.NUM(I,J)*(IDIM+1) XG=XCOOR(IREF-IDIM)+XG YG=XCOOR(IREF-IDIM+1)+YG IF (IDIM.GE.3) ZG=XCOOR(IREF-IDIM+2)+ZG DEN1=XCOOR(IREF)+DEN1 171 CONTINUE 17 CONTINUE XG=XG/(NBNN*NBELEM) YG=YG/(NBNN*NBELEM) ZG=ZG/(NBNN*NBELEM) DEN1=DEN1/(NBNN*NBELEM) IF (IMPOI.EQ.1) DEN1=DEN1D DEN1A=DEN1 DEN1B=DEN1 IF (IOPTG.NE.1) GOTO 13 IREF=IP1*(IDIM+1) IREFT=IREF-IDIM XTRAN=XCOOR(IREF-IDIM) YTRAN=XCOOR(IREF-IDIM+1) ZTRAN=0 IF (IDIM.GE.3) ZTRAN=XCOOR(IREF-IDIM+2) DEN2=XCOOR(IREF) IF (IMPOF.EQ.1) DEN2=DEN2D DEN2A=DEN2 DEN2B=DEN2 XDIS=XTRAN YDIS=YTRAN ZDIS=ZTRAN DLONG=SQRT(XDIS**2+YDIS**2+ZDIS**2) GOTO 16 13 IREF=IP1*(IDIM+1) XROT1(1)=XCOOR(IREF-IDIM) XROT1(2)=XCOOR(IREF-IDIM+1) XROT1(3)=XCOOR(IREF-IDIM+2) IF (IDIM.EQ.2) XROT1(3)=0 DEN2=XCOOR(IREF) IF (IMPOF.EQ.1) DEN2=DEN2D DDIS=ABS(XG-XROT1(1))+ABS(YG-XROT1(2))+ABS(ZG-XROT1(3)) IF (IOPTG.EQ.3) GOTO 15 XROT2(1)=XROT1(1) XROT2(2)=XROT1(2) XROT2(3)=DDIS GOTO 18 15 IREF=IP2*(IDIM+1) XROT2(1)=XCOOR(IREF-IDIM) XROT2(2)=XCOOR(IREF-IDIM+1) XROT2(3)=XCOOR(IREF-IDIM+2) DEN2=(DEN2+XCOOR(IREF))/2.D0 IF (IMPOF.EQ.1) DEN2=DEN2D 18 CONTINUE DEN2A=DEN2 DEN2B=DEN2 XPT1=XROT1(1) YPT1=XROT1(2) ZPT1=XROT1(3) XVEC=XROT2(1)-XROT1(1) YVEC=XROT2(2)-XROT1(2) ZVEC=XROT2(3)-XROT1(3) RAY=SQRT(XVEC**2+YVEC**2+ZVEC**2) XVEC=XVEC/RAY YVEC=YVEC/RAY ZVEC=ZVEC/RAY C Ajout DI VALENTIN : on rajoute la normale dans le C tableau de points NORMAL = nbpts+1 NBPTS = NORMAL SEGADJ MCOORD XCOOR((NORMAL-1)*(IDIM+1)+1) = XVEC XCOOR((NORMAL-1)*(IDIM+1)+2) = YVEC XCOOR((NORMAL-1)*(IDIM+1)+3) = ZVEC C Fin de l'ajout XV1=XG-XROT1(1) YV1=YG-XROT1(2) ZV1=ZG-XROT1(3) PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC XV1=XV1-PV1*XVEC YV1=YV1-PV1*YVEC ZV1=ZV1-PV1*ZVEC RAY=SQRT(XV1**2+YV1**2+ZV1**2) XV1=XV1/RAY YV1=YV1/RAY ZV1=ZV1/RAY XV2=YVEC*ZV1-ZVEC*YV1 YV2=ZVEC*XV1-XVEC*ZV1 ZV2=XVEC*YV1-YVEC*XV1 IREF=IPT1.NUM(1,1)*(IDIM+1)-IDIM X1=XCOOR(IREF) Y1=XCOOR(IREF+1) Z1=XCOOR(IREF+2) IF (IDIM.EQ.2) Z1=0.D0 XV=X1-XPT1 YV=Y1-YPT1 ZV=Z1-ZPT1 PV=XV*XVEC+YV*YVEC+ZV*ZVEC XV=XV-PV*XVEC YV=YV-PV*YVEC ZV=ZV-PV*ZVEC RL1=SQRT(XV**2+YV**2+ZV**2) * ON CREE LES DEUX CENTRES DES CERCLES POUR LES COTES 2 ET 4 NBPTA=nbpts NBPTS=NBPTA+2 SEGADJ MCOORD XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC XCOOR((NBPTA+1)*(IDIM+1))=DEN2 NBPTA=NBPTA+1 NUCEN1=NBPTA IREF=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))*(IDIM+1)-IDIM X1=XCOOR(IREF) Y1=XCOOR(IREF+1) Z1=XCOOR(IREF+2) IF (IDIM.EQ.2) Z1=0.D0 XV=X1-XPT1 YV=Y1-YPT1 ZV=Z1-ZPT1 PV=XV*XVEC+YV*YVEC+ZV*ZVEC XV=XV-PV*XVEC YV=YV-PV*YVEC ZV=ZV-PV*ZVEC RL2=SQRT(XV**2+YV**2+ZV**2) XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC XCOOR((NBPTA+1)*(IDIM+1))=DEN2 NBPTA=NBPTA+1 NUCEN2=NBPTA C RAYON MOYEN C ANGLE EN RADIANS D'OU LONGUEUR MOYENNE DLONG=ABS(RAY*ANGLE) 16 CONTINUE DENI=DEN1 DECA=DEN2-DEN1 DEN1=DEN1/DLONG DEN2=DEN2/DLONG CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG) IF (IERR.NE.0) RETURN IF (IOPTG.NE.1) DLONG=RAY*ANGLE IF (INBR.LE.0) INBR=-NCOUCH NX=NCOUCH-1 IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG 1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5) NBNN=4 NBELEM=IPT1.NUM(/2)*NCOUCH NBSOUS=0 NBREF=4 SEGINI MELEME SEGINI TABPAR ITYPEL=8 IDEB=nbpts+1 INCR=IPT1.ITYPEL-1 NBELEC=IPT1.NUM(/2) SEGINI ICPR C ON FAIT D'ABORD L' EXTREMITEE SEGINI ICPP DO 52 I=1,ICPP1(/1) ICPP1(I)=0 52 CONTINUE IF (IOPTG.NE.1) GOTO 51 ICLE=1 XCO(4)=0 DO 200 I=1,IDIM+1 XCO(I)=XCOOR(IREFT-1+I) 200 CONTINUE CALL ADDITE(XCO,IPT1,IPT3,ICPP,0) IF (IERR.NE.0) RETURN GOTO 50 51 ICLE=2 CALL ADDITE(XROT1,IPT1,IPT3,ICPP,0) 50 CONTINUE SEGSUP ICPP SEGACT IPT3 CALL INVERS(IPT3,IPT4) SEGDES IPT4 LISREF(3)=IPT4 C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS IDEB=nbpts+1 DO 70 I=1,2 DO 701 J=1,NBELEC ICPR1(I,J)=0 701 CONTINUE 70 CONTINUE LCPR=0 DO 71 J=1,NBELEC DO 711 I=1,2 I1=IPT1.NUM((I-1)*INCR+1,J) LCPR=LCPR+1 DO 72 JJ=1,J DO 721 II=1,2 IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 721 IF (II.NE.I) GOTO 73 IF (JJ.EQ.J) GOTO 711 73 ICPR1(I,J)=II+(JJ-1)*2 LCPR=LCPR-1 IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75 GOTO 711 75 IF (IBOUCL.EQ.1) GOTO 711 ICPR1(I,J)=0 ICPR1(II,JJ)=I+(J-1)*2 GOTO 711 721 CONTINUE 72 CONTINUE 711 CONTINUE 71 CONTINUE C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER DIN=DEN1 DO 40 I=1,IPT1.NUM(/2) NUM(1,I)=IPT1.NUM(1,I) NUM(2,I)=IPT1.NUM(1+INCR,I) 40 CONTINUE ILASI=IDEB-1 ILASJ=ILASI+(INCR*NX)+INCR-1 IF (IBOUCL.EQ.1) ILASJ=ILASI ILAS=ILASJ+INCR*NX+INCR DO 42 ICOUCH=1,NCOUCH DIN=DIN*APROG TABPA1(ICOUCH)=DIN IF (NCOUCH.EQ.ICOUCH) GOTO 41 ILASI=ILASI+INCR ILASJ=ILASJ+INCR INI=(ICOUCH-1)*IPT1.NUM(/2) NUM(1,1+INI+NBELEC)=ILASI NUM(4,1+INI)=ILASI NUM(2,INI+2*NBELEC)=ILASJ NUM(3,INI+NBELEC)=ILASJ DO 421 J=1,IPT1.NUM(/2) DO 422 I=1,2 ILL=ILAS IF (I.EQ.1.AND.J.EQ.1) GOTO 422 IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 422 IF (ICPR1(I,J).NE.0) ILL=NUM(MOD(ICPR1(I,J)-1,2)+1, # (ICPR1(I,J)-1)/2+1+INI+NBELEC) NUM(I,J+INI+NBELEC)=ILL NUM(5-I,J+INI)=ILL IF (ICPR1(I,J).NE.0) GOTO 422 ILAS=ILL+1 422 CONTINUE 421 CONTINUE 42 CONTINUE TABPA1(NCOUCH)=DIN*APROG 41 CONTINUE INI=(NCOUCH-1)*IPT1.NUM(/2) DO 43 I=1,NBELEC NUM(4,INI+I)=IPT3.NUM(1,I) NUM(3,INI+I)=IPT3.NUM(1+INCR,I) 43 CONTINUE DO 44 I=1,NCOUCH DO 441 J=1,IPT1.NUM(/2) II=(I-1)*IPT1.NUM(/2)+J ICOLOR(II)=IPT1.ICOLOR(J) 441 CONTINUE 44 CONTINUE LISREF(1)=IPT1 C CREATION DES BORDS LATERAUX PAR LIGNE C PRESENTEMENT CAS DE LA TRANSLATION OU DE LA ROTATION C IMPOSONS ILCOUR POUR CETTE MANIP (LES BORDS LATERAUX DOIVENT ETRE C CONSISTANT AVEC LES AUTRES ) ILSAUV=ILCOUR IDSAUV=IDCOUL ILCOUR=IPT1.ITYPEL IDCOUL=IPT1.ICOLOR(1) ITYPL=1 LP2=IPT3.NUM(1,1) IF (IOPTG.EQ.1) THEN CALL ECROBJ('POINT ',LP2) LP1=IPT1.NUM(1,1) CALL ECROBJ('POINT ',LP1) INBB=INBR CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBB) ELSE ITYPL=3 DEN1A=DEN1A*RL1/RAY DEN2A=DEN2A*RL1/RAY DEN1B=DEN1B*RL2/RAY DEN2B=DEN2B*RL2/RAY LP1=IPT1.NUM(1,1) INBB=INBR CALL ARC(LP1,NUCEN1,NORMAL,ANGLE,INBB,DEN1A,DEN2A,LP2) ENDIF C RESTAURER ILCOUR,IDSAUV ILCOUR=ILSAUV IDCOUL=IDSAUV IF (IERR.NE.0) RETURN CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) SEGACT IPT2 CALL INVERS(IPT2,IPT4) SEGDES IPT2 LISREF(4)=IPT4 SEGDES IPT4 IF (IBOUCL.EQ.0) GOTO 46 LISREF(2)=IPT2 GOTO 45 46 CONTINUE LP1=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2)) IF (IOPTG.EQ.1) THEN CALL ECROBJ('POINT ',LP1) LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) CALL ECROBJ('POINT ',LP1) ILCOUR=IPT1.ITYPEL IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2)) CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR) ELSE LPLAUR = LP1 LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) ILCOUR=IPT1.ITYPEL IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2)) CALL ARC(LP1,NUCEN2,NORMAL,ANGLE,INBB,DEN1B,DEN2B,LPLAUR) ENDIF CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) ILCOUR=ILSAUV IF (IERR.NE.0) RETURN SEGACT IPT2 LISREF(2)=IPT2 45 CONTINUE SEGSUP IPT3 C ON RESTAURE ILCOUR ILCOUR=ILSAUV IDCOUL=IDSAUV C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS) DPAR=0 SEGACT MCOORD*mod IADR=nbpts NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2 SEGADJ MCOORD IF (NCOUCH.EQ.1) GOTO 60 DO 61 I=2,NCOUCH DIN=TABPA1(I-1) DPAR=DPAR+DIN IF (IOPTG.EQ.1) GOTO 83 ANG=DPAR*DLONG/RAY SI=SIN(ANG) CO=COS(ANG) 83 CONTINUE IF (IPT1.NUM(/2).EQ.1) GOTO 60 DO 62 J=1,IPT1.NUM(/2) DO 621 K=1,2 IF (K.EQ.1.AND.J.EQ.1) GOTO 621 IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 621 IF (ICPR1(K,J).NE.0) GOTO 621 IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM IF (IOPTG.NE.1) GOTO 84 XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+DPAR*XDIS XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+DPAR*YDIS IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+DPAR $ *ZDIS GOTO 85 84 X1=XCOOR(IREF)-XPT1 Y1=XCOOR(IREF+1)-YPT1 Z1=XCOOR(IREF+2)-ZPT1 IF (IDIM.EQ.2) Z1=0 XV=X1*XV1+Y1*YV1+Z1*ZV1 YV=X1*XV2+Y1*YV2+Z1*ZV2 ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC XD=XV*CO-YV*SI YD=XV*SI+YV*CO ZD=ZV XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD $ *ZVEC+ZPT1 85 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR IADR=IADR+1 621 CONTINUE 62 CONTINUE 61 CONTINUE 60 CONTINUE NBPTS=IADR SEGADJ MCOORD IF (KSURF(ILCOUR).EQ.8) GOTO 101 IF (KSURF(ILCOUR).NE.4) GOTO 102 NBNN=3 NBELEM=2*NUM(/2) NBREF=4 NBSOUS=0 SEGINI IPT1 IPT1.ITYPEL=4 IPT1.LISREF(1)=LISREF(1) IPT1.LISREF(2)=LISREF(2) IPT1.LISREF(3)=LISREF(3) IPT1.LISREF(4)=LISREF(4) DO 103 I=1,NUM(/2),2 J=2*I-1 IPT1.NUM(1,J)=NUM(1,I) IPT1.NUM(2,J)=NUM(2,I) IPT1.NUM(3,J)=NUM(3,I) IPT1.ICOLOR(J)=ICOLOR(I) J=J+1 IPT1.NUM(1,J)=NUM(1,I) IPT1.NUM(2,J)=NUM(3,I) IPT1.NUM(3,J)=NUM(4,I) IPT1.ICOLOR(J)=ICOLOR(I) J=J+1 IF (J.GT.IPT1.NUM(/2)) GOTO 103 IPT1.NUM(1,J)=NUM(1,I+1) IPT1.NUM(2,J)=NUM(2,I+1) IPT1.NUM(3,J)=NUM(4,I+1) IPT1.ICOLOR(J)=ICOLOR(I+1) J=J+1 IPT1.NUM(1,J)=NUM(2,I+1) IPT1.NUM(2,J)=NUM(3,I+1) IPT1.NUM(3,J)=NUM(4,I+1) IPT1.ICOLOR(J)=ICOLOR(I+1) 103 CONTINUE SEGSUP MELEME MELEME=IPT1 GOTO 101 102 CONTINUE IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104 C ON FAIT DES QUA8 OU DES TRI6 NBNN=8 NBELEM=NUM(/2) NBREF=4 NBSOUS=0 SEGINI IPT5 IPT5.ITYPEL=10 IPT1=LISREF(1) IPT2=LISREF(2) IPT3=LISREF(3) IPT4=LISREF(4) IPT5.LISREF(1)=IPT1 IPT5.LISREF(2)=IPT2 IPT5.LISREF(3)=IPT3 IPT5.LISREF(4)=IPT4 SEGACT IPT1,IPT2,IPT3,IPT4 DO 105 J=1,NUM(/1) JJ=2*J-1 DO 1051 I=1,NBELEM IPT5.NUM(JJ,I)=NUM(J,I) 1051 CONTINUE 105 CONTINUE DO 135 I=1,NBELEM IPT5.ICOLOR(I)=ICOLOR(I) 135 CONTINUE NLIG=IPT1.NUM(/2) DO 106 I=1,NLIG IPT5.NUM(2,I)=IPT1.NUM(2,I) IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I) 106 CONTINUE DPAR=0 NBPTS=IADR+NCOUCH*NLIG*3 SEGADJ MCOORD DO 107 I=1,NCOUCH IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I) IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I) C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS) C CREATION DES NOEUDS DIN=TABPA1(I) DPAR=DPAR+DIN IF (IOPTG.EQ.1) GOTO 110 ANG=DPAR*DLONG/RAY SI=SIN(ANG) CO=COS(ANG) 110 CONTINUE IF (I.EQ.NCOUCH) GOTO 108 DO 109 J=1,NLIG IREF=(IDIM+1)*(IPT1.NUM(2,J)-1) IF (IOPTG.NE.1) GOTO 111 XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+DPAR*XDIS XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+DPAR*YDIS IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+DPAR $ *ZDIS GOTO 112 111 X1=XCOOR(IREF+1)-XPT1 Y1=XCOOR(IREF+2)-YPT1 Z1=XCOOR(IREF+3)-ZPT1 IF (IDIM.EQ.2) Z1=0.D0 XV=X1*XV1+Y1*YV1+Z1*ZV1 YV=X1*XV2+Y1*YV2+Z1*ZV2 ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC XD=XV*CO-YV*SI YD=XV*SI+YV*CO ZD=ZV XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC $ +ZPT1 112 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR IADR=IADR+1 C ON MET LE NOEUD DANS LES ELEMENTS IPT5.NUM(6,(I-1)*NLIG+J)=IADR IPT5.NUM(2,I*NLIG+J)=IADR 109 CONTINUE 108 CONTINUE IF (NLIG.EQ.1) GOTO 113 C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE C CREATION DES NOEUDS EPAR=DPAR-TABPA1(I)*0.5D0 IF (IOPTG.EQ.1) GOTO 114 ANG=EPAR*DLONG/RAY SI=SIN(ANG) CO=COS(ANG) 114 CONTINUE DO 115 J=1,NLIG DO 1151 K=1,2 IF (K.EQ.1.AND.J.EQ.1) GOTO 1151 IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1151 IF (ICPR1(K,J).NE.0) GOTO 116 IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1) IF (IOPTG.NE.1) GOTO 117 XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR $ *ZDIS GOTO 118 117 X1=XCOOR(IREF+1)-XPT1 Y1=XCOOR(IREF+2)-YPT1 Z1=XCOOR(IREF+3)-ZPT1 IF (IDIM.EQ.2) Z1=0 XV=X1*XV1+Y1*YV1+Z1*ZV1 YV=X1*XV2+Y1*YV2+Z1*ZV2 ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC XD=XV*CO-YV*SI YD=XV*SI+YV*CO ZD=ZV XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD $ *ZVEC+ZPT1 118 XCOOR((IADR+1)*(IDIM+1))=DEN1+DECA*EPAR IADR=IADR+1 116 CONTINUE C NOEUDS DES ELEM IF (ICPR1(K,J).NE.0) GOTO 119 IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR GOTO 1151 119 CONTINUE IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR1(K $ ,J)-1,2)),(ICPR1(K,J)+1)/2+(I-1)*NLIG) 1151 CONTINUE 115 CONTINUE 113 CONTINUE 107 CONTINUE NBPTS=IADR SEGADJ MCOORD SEGSUP MELEME MELEME=IPT5 SEGDES IPT1,IPT2,IPT3,IPT4 IF (KSURF(ILCOUR).NE.6) GOTO 101 C ON FAIT DES TRI6 NBNN=6 NBELEM=2*NUM(/2) NBREF=4 NBSOUS=0 SEGINI IPT1 IPT1.ITYPEL=6 IPT1.LISREF(1)=LISREF(1) IPT1.LISREF(2)=LISREF(2) IPT1.LISREF(3)=LISREF(3) IPT1.LISREF(4)=LISREF(4) DPAR=0 IALT=1 NBPTS=IADR+NCOUCH*NLIG SEGADJ MCOORD DO 120 I=1,NCOUCH DIN=TABPA1(I) DPAR=DPAR+DIN EPAR=DPAR-DIN*0.5D0 IF (IOPTG.EQ.1) GOTO 121 ANG=EPAR*DLONG/RAY SI=SIN(ANG) CO=COS(ANG) 121 CONTINUE DO 1201 J=1,NLIG INU=(I-1)*NLIG+J IALT=3-IALT C CREATION DU POINT SUPPLEMENTAIRE IREF=(NUM(2,J)-1)*(IDIM+1) IF (IOPTG.NE.1) GOTO 122 XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR $ *ZDIS GOTO 123 122 X1=XCOOR(IREF+1)-XPT1 Y1=XCOOR(IREF+2)-YPT1 Z1=XCOOR(IREF+3)-ZPT1 IF (IDIM.EQ.2) Z1=0.D0 XV=X1*XV1+Y1*YV1+Z1*ZV1 YV=X1*XV2+Y1*YV2+Z1*ZV2 ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC XD=XV*CO-YV*SI YD=XV*SI+YV*CO ZD=ZV XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC $ +ZPT1 123 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*EPAR IADR=IADR+1 ITR1=2*INU-1 ITR2=2*INU GOTO (124,125),IALT C CREATION DES TRIANGLES 124 IPT1.NUM(1,ITR1)=NUM(1,INU) IPT1.NUM(2,ITR1)=NUM(2,INU) IPT1.NUM(3,ITR1)=NUM(3,INU) IPT1.NUM(5,ITR1)=NUM(7,INU) IPT1.NUM(6,ITR1)=NUM(8,INU) IPT1.NUM(4,ITR1)=IADR IPT1.NUM(1,ITR2)=NUM(3,INU) IPT1.NUM(2,ITR2)=NUM(4,INU) IPT1.NUM(3,ITR2)=NUM(5,INU) IPT1.NUM(4,ITR2)=NUM(6,INU) IPT1.NUM(5,ITR2)=NUM(7,INU) IPT1.NUM(6,ITR2)=IADR IPT1.ICOLOR(ITR1)=ICOLOR(INU) IPT1.ICOLOR(ITR2)=ICOLOR(INU) GOTO 126 125 IPT1.NUM(1,ITR1)=NUM(1,INU) IPT1.NUM(2,ITR1)=NUM(2,INU) IPT1.NUM(3,ITR1)=NUM(3,INU) IPT1.NUM(4,ITR1)=NUM(4,INU) IPT1.NUM(5,ITR1)=NUM(5,INU) IPT1.NUM(6,ITR1)=IADR IPT1.NUM(1,ITR2)=NUM(5,INU) IPT1.NUM(2,ITR2)=NUM(6,INU) IPT1.NUM(3,ITR2)=NUM(7,INU) IPT1.NUM(4,ITR2)=NUM(8,INU) IPT1.NUM(5,ITR2)=NUM(1,INU) IPT1.NUM(6,ITR2)=IADR IPT1.ICOLOR(ITR1)=ICOLOR(INU) IPT1.ICOLOR(ITR2)=ICOLOR(INU) GOTO 126 126 CONTINUE 1201 CONTINUE 120 CONTINUE SEGSUP MELEME MELEME=IPT1 GOTO 101 104 CONTINUE 101 CONTINUE SEGSUP TABPAR,ICPR C S'IL Y A LIEU EXAMINER LA DEGENERESCENCE (ROTATION) SEGDES IPT1 ** degsur n'a pas grand sens en 3D et ne marche pas ***** IF (IOPTG.NE.1) CALL DEGSUR(MELEME,IP1,IP2) IF (IFUSE.EQ.0) GOTO 63 IPT5=IFUSE SEGACT IPT5,MELEME ltelq=.false. CALL FUSE(IPT5,MELEME,IRET,ltelq) SEGACT IPT5,MELEME IF (ITYPEL.EQ.IPT5.ITYPEL) SEGSUP MELEME SEGDES IPT5 MELEME=IRET 63 CONTINUE CALL ECROBJ('MAILLAGE',MELEME) SEGDES MELEME RETURN END