Télécharger la plaquette Cast3M


fr en

Télécharger prtran.eso

Retour à la liste

Numérotation des lignes : 

prtran

  1. C PRTRAN    SOURCE    SP204843  25/01/30    21:15:03     12141          
  2. C    PREPARATION DE LA TRANSLATION ET DE LA ROTATION D'UNE LIGNE
  3. C
  4. C  MODIFICATION NOVEMBRE 1984 INTRODUCTION DE LA DEGENERESCENCE DANS
  5. C   LE CAS DE ROTATION DONT L'AXE PASSE PAR UN (OU DEUX) POINT DE
  6. C   LA LIGNE (MODIFICATION NON TERMINE)
  7. C
  8.       SUBROUTINE PRTRAN(IOPTG)
  9.       IMPLICIT INTEGER(I-N)
  10.       IMPLICIT REAL*8 (A-H,O-Z)
  11.       DIMENSION XCO(4)
  12.       DIMENSION XROT1(3),XROT2(3)
  13.       CHARACTER*4 MCLE(2)
  14. -INC CCREEL
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18.       logical ltelq
  19.       SEGMENT TABPAR
  20.       REAL*8 TABPA1(NCOUCH)
  21.       ENDSEGMENT
  22. -INC CCGEOME
  23. -INC SMCOORD
  24. -INC SMELEME
  25.       SEGMENT ICPR
  26.       INTEGER ICPR1(2,NBELEC)
  27.       ENDSEGMENT
  28.       SEGMENT ICPP
  29.       INTEGER ICPP1(nbpts)
  30.       ENDSEGMENT
  31.       COMMON/CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC,
  32.      #     ZVEC,ANGLE,ICLE,XP1,YP1,ZP1
  33.       DATA MCLE/'DINI','DFIN'/
  34.       XDIS=0.D0
  35.       YDIS=0.D0
  36.       ZDIS=0.D0
  37.       IMPOI=0
  38.       IMPOF=0
  39. C  Y A T IL UN DECOUPAGE IMPOSE
  40.       INBR=0
  41.       CALL MESLIR(-236)
  42.       CALL LIRENT(INBR,0,IRETOU)
  43.  
  44. *      IF (IRETOU.EQ.1) INBR=MAX(1,INBR)
  45.       IF (IDIM.EQ.3.AND.IOPTG.EQ.2) IOPTG=3
  46.       IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
  47. C  CAS DE LA ROTATION DONNEE OBLIGATOIRE  L'ANGLE
  48.       IF (IOPTG.EQ.1) GOTO 1
  49.       IOB=0
  50.       IF (INBR.EQ.0) IOB=1
  51.       CALL MESLIR(-235)
  52.       CALL LIRREE(XXX,IOB,IRETOU)
  53.       FLOT=XXX
  54.       IF (IERR.NE.0) RETURN
  55.       IF (IRETOU.EQ.1) GOTO 2
  56.       IF (INBR.NE.0) FLOT=INBR
  57.       INBR=0
  58.  2    CONTINUE
  59.       ANGLE=FLOT*XPI/180.D0
  60.  
  61.       IF (IERR.NE.0) RETURN
  62.  1    CONTINUE
  63. C  Y A T-IL DES DENSITES IMPOSEES
  64.  3    CONTINUE
  65.       CALL MESLIR(-234)
  66.       CALL LIRMOT(MCLE,2,IRETOU,0)
  67.       IF (IRETOU.EQ.1) THEN
  68.          CALL MESLIR(-170)
  69.          CALL LIRREE(XXX,1,IRETOU)
  70.          DEN1D=XXX
  71.          IF (IERR.NE.0) RETURN
  72.          IMPOI=1
  73.          GOTO 3
  74.       ELSEIF (IRETOU.EQ.2) THEN
  75.          CALL MESLIR(-169)
  76.          CALL LIRREE(XXX,1,IRETOU)
  77.          DEN2D=XXX
  78.          IF (IERR.NE.0) RETURN
  79.          IMPOF=1
  80.          GOTO 3
  81.       ENDIF
  82.       CALL MESLIR(-131)
  83.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  84.       IF (IERR.NE.0) RETURN
  85.       CALL EXTRLI(IPT1,3,IRET,-1)
  86.       IF (IERR.NE.0) RETURN
  87.       IFUSE=0
  88.       IF (IPT1.NE.IRET) IFUSE=IPT1
  89.       IPT1=IRET
  90.       IF (IOPTG.EQ.1) CALL MESLIR(-233)
  91.       IF (IOPTG.EQ.2) CALL MESLIR(-232)
  92.       CALL LIROBJ('POINT ',IP1,1,IRETOU)
  93.       IF (IOPTG.EQ.3) THEN
  94.          CALL MESLIR(-231)
  95.          CALL LIROBJ('POINT ',IP2,1,IRETOU)
  96.          IF (IERR.NE.0) RETURN
  97.       ENDIF
  98.  12   SEGACT IPT1
  99.  11   SEGACT MCOORD*mod
  100.       NBNN=IPT1.NUM(/1)
  101. *  VERIFIER TYPE D'ELEMENT ACCEPTABLE
  102.       IF (IPT1.ITYPEL.NE.2.AND.IPT1.ITYPEL.NE.3) CALL ERREUR(16)
  103.       IF (IERR.NE.0) RETURN
  104.       NBELEM=IPT1.NUM(/2)
  105.       XG1=0.D0
  106.       YG1=0.D0
  107.       ZG1=0.D0
  108.       XL1=0.D0
  109.       YL1=0.D0
  110.       ZL1=0.D0
  111.       XG=0.D0
  112.       YG=0.D0
  113.       ZG=0.D0
  114.       DEN1=0.D0
  115.       IBOUCL=0
  116.       IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1
  117.       DO 17 I=1,NBNN
  118.          DO 171 J=1,NBELEM
  119.             IREF=IPT1.NUM(I,J)*(IDIM+1)
  120.             XG=XCOOR(IREF-IDIM)+XG
  121.             YG=XCOOR(IREF-IDIM+1)+YG
  122.             IF (IDIM.GE.3) ZG=XCOOR(IREF-IDIM+2)+ZG
  123.             DEN1=XCOOR(IREF)+DEN1
  124.             IF (XCOOR(IREF-IDIM  ).GT.XG1) XG1 = XCOOR(IREF-IDIM)
  125.             IF (XCOOR(IREF-IDIM+1).GT.YG1) YG1 = XCOOR(IREF-IDIM+1)
  126.             IF (XCOOR(IREF-IDIM  ).LT.XG1) XL1 = XCOOR(IREF-IDIM)
  127.             IF (XCOOR(IREF-IDIM+1).LT.YG1) YL1 = XCOOR(IREF-IDIM+1)
  128.             IF (IDIM.GE.3) THEN
  129.             IF (XCOOR(IREF-IDIM+2).GT.ZG1) ZG1 = XCOOR(IREF-IDIM+2)
  130.             IF (XCOOR(IREF-IDIM+2).LT.ZL1) ZL1 = XCOOR(IREF-IDIM+2)
  131.             ENDIF
  132.  171     CONTINUE
  133.  17   CONTINUE
  134.       XG=XG/(NBNN*NBELEM)
  135.       YG=YG/(NBNN*NBELEM)
  136.       ZG=ZG/(NBNN*NBELEM)
  137.       DEN1=DEN1/(NBNN*NBELEM)
  138.       DL1=SQRT((XG1-XL1)**2+(YG1-YL1)**2+(ZG1-ZL1)**2)
  139.       DL1=DL1/NBELEM
  140.       IF (IMPOI.EQ.1) DEN1=DEN1D
  141.       DEN1A=DEN1
  142.       DEN1B=DEN1
  143.       IF (IOPTG.NE.1) GOTO 13
  144.       IREF=IP1*(IDIM+1)
  145.       IREFT=IREF-IDIM
  146.       XTRAN=XCOOR(IREF-IDIM)
  147.       YTRAN=XCOOR(IREF-IDIM+1)
  148.       ZTRAN=0
  149.       IF (IDIM.GE.3) ZTRAN=XCOOR(IREF-IDIM+2)
  150.       DEN2=XCOOR(IREF)
  151.       IF (IMPOF.EQ.1) DEN2=DEN2D
  152.       DEN2A=DEN2
  153.       DEN2B=DEN2
  154.       XDIS=XTRAN
  155.       YDIS=YTRAN
  156.       ZDIS=ZTRAN
  157.       DLONG=SQRT(XDIS**2+YDIS**2+ZDIS**2)
  158.       IF (ABS(DL1*DLONG).LT.XZPREC) THEN
  159.         CALL ERREUR(21)
  160.         RETURN
  161.       ENDIF
  162.       GOTO 16
  163.  13   IREF=IP1*(IDIM+1)
  164.       XROT1(1)=XCOOR(IREF-IDIM)
  165.       XROT1(2)=XCOOR(IREF-IDIM+1)
  166.       XROT1(3)=XCOOR(IREF-IDIM+2)
  167.       IF (IDIM.EQ.2) XROT1(3)=0
  168.       DEN2=XCOOR(IREF)
  169.       IF (IMPOF.EQ.1) DEN2=DEN2D
  170.       DDIS=ABS(XG-XROT1(1))+ABS(YG-XROT1(2))+ABS(ZG-XROT1(3))
  171.       IF (IOPTG.EQ.3) GOTO 15
  172.       XROT2(1)=XROT1(1)
  173.       XROT2(2)=XROT1(2)
  174.       XROT2(3)=DDIS
  175.       GOTO 18
  176.  15   IREF=IP2*(IDIM+1)
  177.       XROT2(1)=XCOOR(IREF-IDIM)
  178.       XROT2(2)=XCOOR(IREF-IDIM+1)
  179.       XROT2(3)=XCOOR(IREF-IDIM+2)
  180.       DEN2=(DEN2+XCOOR(IREF))/2.D0
  181.       IF (IMPOF.EQ.1) DEN2=DEN2D
  182.  18   CONTINUE
  183.       DEN2A=DEN2
  184.       DEN2B=DEN2
  185.       XPT1=XROT1(1)
  186.       YPT1=XROT1(2)
  187.       ZPT1=XROT1(3)
  188.       XVEC=XROT2(1)-XROT1(1)
  189.       YVEC=XROT2(2)-XROT1(2)
  190.       ZVEC=XROT2(3)-XROT1(3)
  191.       RAY=SQRT(XVEC**2+YVEC**2+ZVEC**2)
  192.       XVEC=XVEC/RAY
  193.       YVEC=YVEC/RAY
  194.       ZVEC=ZVEC/RAY
  195.  
  196. C     Ajout DI VALENTIN : on rajoute la normale dans le
  197. C                         tableau de points
  198.  
  199.       NORMAL = nbpts+1
  200.       NBPTS  = NORMAL
  201.       SEGADJ MCOORD
  202.  
  203.       XCOOR((NORMAL-1)*(IDIM+1)+1) = XVEC
  204.       XCOOR((NORMAL-1)*(IDIM+1)+2) = YVEC
  205.       XCOOR((NORMAL-1)*(IDIM+1)+3) = ZVEC
  206.  
  207. C    Fin de l'ajout
  208.  
  209.  
  210.       XV1=XG-XROT1(1)
  211.       YV1=YG-XROT1(2)
  212.       ZV1=ZG-XROT1(3)
  213.       PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC
  214.       XV1=XV1-PV1*XVEC
  215.       YV1=YV1-PV1*YVEC
  216.       ZV1=ZV1-PV1*ZVEC
  217.       RAY=SQRT(XV1**2+YV1**2+ZV1**2)
  218.       XV1=XV1/RAY
  219.       YV1=YV1/RAY
  220.       ZV1=ZV1/RAY
  221.       XV2=YVEC*ZV1-ZVEC*YV1
  222.       YV2=ZVEC*XV1-XVEC*ZV1
  223.       ZV2=XVEC*YV1-YVEC*XV1
  224.       IREF=IPT1.NUM(1,1)*(IDIM+1)-IDIM
  225.       X1=XCOOR(IREF)
  226.       Y1=XCOOR(IREF+1)
  227.       Z1=XCOOR(IREF+2)
  228.       IF (IDIM.EQ.2) Z1=0.D0
  229.       XV=X1-XPT1
  230.       YV=Y1-YPT1
  231.       ZV=Z1-ZPT1
  232.       PV=XV*XVEC+YV*YVEC+ZV*ZVEC
  233.       XV=XV-PV*XVEC
  234.       YV=YV-PV*YVEC
  235.       ZV=ZV-PV*ZVEC
  236.       RL1=SQRT(XV**2+YV**2+ZV**2)
  237. * ON CREE LES DEUX CENTRES DES CERCLES POUR LES COTES 2 ET 4
  238.       NBPTA=nbpts
  239.       NBPTS=NBPTA+2
  240.       SEGADJ MCOORD
  241.       XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC
  242.       XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC
  243.       IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC
  244.       XCOOR((NBPTA+1)*(IDIM+1))=DEN2
  245.       NBPTA=NBPTA+1
  246.       NUCEN1=NBPTA
  247.       IREF=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))*(IDIM+1)-IDIM
  248.       X1=XCOOR(IREF)
  249.       Y1=XCOOR(IREF+1)
  250.       Z1=XCOOR(IREF+2)
  251.       IF (IDIM.EQ.2) Z1=0.D0
  252.       XV=X1-XPT1
  253.       YV=Y1-YPT1
  254.       ZV=Z1-ZPT1
  255.       PV=XV*XVEC+YV*YVEC+ZV*ZVEC
  256.       XV=XV-PV*XVEC
  257.       YV=YV-PV*YVEC
  258.       ZV=ZV-PV*ZVEC
  259.       RL2=SQRT(XV**2+YV**2+ZV**2)
  260.       XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC
  261.       XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC
  262.       IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC
  263.       XCOOR((NBPTA+1)*(IDIM+1))=DEN2
  264.       NBPTA=NBPTA+1
  265.       NUCEN2=NBPTA
  266. C  RAYON MOYEN
  267. C  ANGLE EN RADIANS D'OU LONGUEUR MOYENNE
  268.       DLONG=ABS(RAY*ANGLE)
  269.  16   CONTINUE
  270.       DENI=DEN1
  271.       DECA=DEN2-DEN1
  272.       DEN1=DEN1/DLONG
  273.       DEN2=DEN2/DLONG
  274.       CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  275.       IF (IERR.NE.0) RETURN
  276.       IF (IOPTG.NE.1) DLONG=RAY*ANGLE
  277.       IF (INBR.LE.0) INBR=-NCOUCH
  278.       NX=NCOUCH-1
  279.       IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG
  280.  1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  281.       NBNN=4
  282.       NBELEM=IPT1.NUM(/2)*NCOUCH
  283.       NBSOUS=0
  284.       NBREF=4
  285.       SEGINI MELEME
  286.       SEGINI TABPAR
  287.       ITYPEL=8
  288.       IDEB=nbpts+1
  289.       INCR=IPT1.ITYPEL-1
  290.       NBELEC=IPT1.NUM(/2)
  291.       SEGINI ICPR
  292. C    ON FAIT D'ABORD L' EXTREMITEE
  293.       SEGINI ICPP
  294.       DO 52 I=1,ICPP1(/1)
  295.          ICPP1(I)=0
  296.  52   CONTINUE
  297.       IF (IOPTG.NE.1) GOTO 51
  298.       ICLE=1
  299.       XCO(4)=0
  300.       DO 200 I=1,IDIM+1
  301.          XCO(I)=XCOOR(IREFT-1+I)
  302.  200  CONTINUE
  303.       CALL ADDITE(XCO,IPT1,IPT3,ICPP,0)
  304.       IF (IERR.NE.0) RETURN
  305.       GOTO 50
  306.  51   ICLE=2
  307.       CALL ADDITE(XROT1,IPT1,IPT3,ICPP,0)
  308.  50   CONTINUE
  309.       SEGSUP ICPP
  310.       SEGACT IPT3
  311.       CALL INVERS(IPT3,IPT4)
  312.       SEGDES IPT4
  313.       LISREF(3)=IPT4
  314. C    ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
  315.       IDEB=nbpts+1
  316.       DO 70 I=1,2
  317.          DO 701 J=1,NBELEC
  318.             ICPR1(I,J)=0
  319.  701     CONTINUE
  320.  70   CONTINUE
  321.       LCPR=0
  322.       DO 71 J=1,NBELEC
  323.          DO 711 I=1,2
  324.             I1=IPT1.NUM((I-1)*INCR+1,J)
  325.             LCPR=LCPR+1
  326.             DO 72 JJ=1,J
  327.                DO 721 II=1,2
  328.                   IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 721
  329.                   IF (II.NE.I) GOTO 73
  330.                   IF (JJ.EQ.J) GOTO 711
  331.  73               ICPR1(I,J)=II+(JJ-1)*2
  332.                   LCPR=LCPR-1
  333.                   IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75
  334.                   GOTO 711
  335.  75               IF (IBOUCL.EQ.1) GOTO 711
  336.                   ICPR1(I,J)=0
  337.                   ICPR1(II,JJ)=I+(J-1)*2
  338.                   GOTO 711
  339.  721           CONTINUE
  340.  72         CONTINUE
  341.  711     CONTINUE
  342.  71   CONTINUE
  343. C   ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
  344. C    LE MOMENT   D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
  345.       DIN=DEN1
  346.       DO 40 I=1,IPT1.NUM(/2)
  347.          NUM(1,I)=IPT1.NUM(1,I)
  348.          NUM(2,I)=IPT1.NUM(1+INCR,I)
  349.  40   CONTINUE
  350.       ILASI=IDEB-1
  351.       ILASJ=ILASI+(INCR*NX)+INCR-1
  352.       IF (IBOUCL.EQ.1) ILASJ=ILASI
  353.       ILAS=ILASJ+INCR*NX+INCR
  354.       DO 42 ICOUCH=1,NCOUCH
  355.          DIN=DIN*APROG
  356.          TABPA1(ICOUCH)=DIN
  357.          IF (NCOUCH.EQ.ICOUCH) GOTO 41
  358.          ILASI=ILASI+INCR
  359.          ILASJ=ILASJ+INCR
  360.          INI=(ICOUCH-1)*IPT1.NUM(/2)
  361.          NUM(1,1+INI+NBELEC)=ILASI
  362.          NUM(4,1+INI)=ILASI
  363.          NUM(2,INI+2*NBELEC)=ILASJ
  364.          NUM(3,INI+NBELEC)=ILASJ
  365.          DO 421 J=1,IPT1.NUM(/2)
  366.             DO 422 I=1,2
  367.                ILL=ILAS
  368.                IF (I.EQ.1.AND.J.EQ.1) GOTO 422
  369.                IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 422
  370.                IF (ICPR1(I,J).NE.0) ILL=NUM(MOD(ICPR1(I,J)-1,2)+1,
  371.      #              (ICPR1(I,J)-1)/2+1+INI+NBELEC)
  372.                NUM(I,J+INI+NBELEC)=ILL
  373.                NUM(5-I,J+INI)=ILL
  374.                IF (ICPR1(I,J).NE.0) GOTO 422
  375.                ILAS=ILL+1
  376.  422        CONTINUE
  377.  421     CONTINUE
  378.  42   CONTINUE
  379.       TABPA1(NCOUCH)=DIN*APROG
  380.  41   CONTINUE
  381.       INI=(NCOUCH-1)*IPT1.NUM(/2)
  382.       DO 43 I=1,NBELEC
  383.          NUM(4,INI+I)=IPT3.NUM(1,I)
  384.          NUM(3,INI+I)=IPT3.NUM(1+INCR,I)
  385.  43   CONTINUE
  386.       DO 44 I=1,NCOUCH
  387.          DO 441 J=1,IPT1.NUM(/2)
  388.             II=(I-1)*IPT1.NUM(/2)+J
  389.             ICOLOR(II)=IPT1.ICOLOR(J)
  390.  441     CONTINUE
  391.  44   CONTINUE
  392.       LISREF(1)=IPT1
  393. C   CREATION DES BORDS LATERAUX PAR LIGNE
  394. C     PRESENTEMENT CAS DE LA TRANSLATION OU DE LA ROTATION
  395. C   IMPOSONS ILCOUR POUR CETTE MANIP   (LES BORDS LATERAUX DOIVENT ETRE
  396. C    CONSISTANT AVEC LES AUTRES  )
  397.       ILSAUV=ILCOUR
  398.       IDSAUV=IDCOUL
  399.       ILCOUR=IPT1.ITYPEL
  400.       IDCOUL=IPT1.ICOLOR(1)
  401.       ITYPL=1
  402.       LP2=IPT3.NUM(1,1)
  403.  
  404.       IF (IOPTG.EQ.1) THEN
  405.          CALL ECROBJ('POINT ',LP2)
  406.          LP1=IPT1.NUM(1,1)
  407.          CALL ECROBJ('POINT ',LP1)
  408.          INBB=INBR
  409.          CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBB)
  410.  
  411.       ELSE
  412.          ITYPL=3
  413.          DEN1A=DEN1A*RL1/RAY
  414.          DEN2A=DEN2A*RL1/RAY
  415.          DEN1B=DEN1B*RL2/RAY
  416.          DEN2B=DEN2B*RL2/RAY
  417.          LP1=IPT1.NUM(1,1)
  418.          INBB=INBR
  419.          CALL ARC(LP1,NUCEN1,NORMAL,ANGLE,INBB,DEN1A,DEN2A,LP2)
  420.       ENDIF
  421.  
  422. C  RESTAURER ILCOUR,IDSAUV
  423.       ILCOUR=ILSAUV
  424.       IDCOUL=IDSAUV
  425.       IF (IERR.NE.0) RETURN
  426.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  427.       SEGACT IPT2
  428.       CALL INVERS(IPT2,IPT4)
  429.       SEGDES IPT2
  430.       LISREF(4)=IPT4
  431.       SEGDES IPT4
  432.       IF (IBOUCL.EQ.0) GOTO 46
  433.       LISREF(2)=IPT2
  434.       GOTO 45
  435.  46   CONTINUE
  436.       LP1=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2))
  437.  
  438.       IF (IOPTG.EQ.1) THEN
  439.          CALL ECROBJ('POINT ',LP1)
  440.          LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  441.          CALL ECROBJ('POINT ',LP1)
  442.          ILCOUR=IPT1.ITYPEL
  443.          IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2))
  444.          CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR)
  445.  
  446.       ELSE
  447.          LPLAUR = LP1
  448.          LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  449.          ILCOUR=IPT1.ITYPEL
  450.          IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2))
  451.          CALL ARC(LP1,NUCEN2,NORMAL,ANGLE,INBB,DEN1B,DEN2B,LPLAUR)
  452.  
  453.       ENDIF
  454.  
  455.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  456.       ILCOUR=ILSAUV
  457.       IF (IERR.NE.0) RETURN
  458.       SEGACT IPT2
  459.       LISREF(2)=IPT2
  460.  45   CONTINUE
  461.       SEGSUP IPT3
  462. C   ON RESTAURE ILCOUR
  463.       ILCOUR=ILSAUV
  464.       IDCOUL=IDSAUV
  465. C    CREATION DES POINTS  (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
  466. C     EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
  467.       DPAR=0
  468.       SEGACT MCOORD*mod
  469.       IADR=nbpts
  470.       NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2
  471.       SEGADJ MCOORD
  472.       IF (NCOUCH.EQ.1) GOTO 60
  473.       DO 61 I=2,NCOUCH
  474.          DIN=TABPA1(I-1)
  475.          DPAR=DPAR+DIN
  476.          IF (IOPTG.EQ.1) GOTO 83
  477.          ANG=DPAR*DLONG/RAY
  478.          SI=SIN(ANG)
  479.          CO=COS(ANG)
  480.  83      CONTINUE
  481.          IF (IPT1.NUM(/2).EQ.1) GOTO 60
  482.          DO 62 J=1,IPT1.NUM(/2)
  483.             DO 621 K=1,2
  484.                IF (K.EQ.1.AND.J.EQ.1) GOTO 621
  485.                IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 621
  486.                IF (ICPR1(K,J).NE.0) GOTO 621
  487.                IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM
  488.                IF (IOPTG.NE.1) GOTO 84
  489.                XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+DPAR*XDIS
  490.                XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+DPAR*YDIS
  491.                IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+DPAR
  492.      $              *ZDIS
  493.                GOTO 85
  494.  84            X1=XCOOR(IREF)-XPT1
  495.                Y1=XCOOR(IREF+1)-YPT1
  496.                Z1=XCOOR(IREF+2)-ZPT1
  497.                IF (IDIM.EQ.2) Z1=0
  498.                XV=X1*XV1+Y1*YV1+Z1*ZV1
  499.                YV=X1*XV2+Y1*YV2+Z1*ZV2
  500.                ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  501.                XD=XV*CO-YV*SI
  502.                YD=XV*SI+YV*CO
  503.                ZD=ZV
  504.                XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  505.                XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  506.                IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD
  507.      $              *ZVEC+ZPT1
  508.  85            XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  509.                IADR=IADR+1
  510.  621        CONTINUE
  511.  62      CONTINUE
  512.  61   CONTINUE
  513.  60   CONTINUE
  514.       NBPTS=IADR
  515.       SEGADJ MCOORD
  516.       IF (KSURF(ILCOUR).EQ.8) GOTO 101
  517.       IF (KSURF(ILCOUR).NE.4) GOTO 102
  518.       NBNN=3
  519.       NBELEM=2*NUM(/2)
  520.       NBREF=4
  521.       NBSOUS=0
  522.       SEGINI IPT1
  523.       IPT1.ITYPEL=4
  524.       IPT1.LISREF(1)=LISREF(1)
  525.       IPT1.LISREF(2)=LISREF(2)
  526.       IPT1.LISREF(3)=LISREF(3)
  527.       IPT1.LISREF(4)=LISREF(4)
  528.       DO 103 I=1,NUM(/2),2
  529.          J=2*I-1
  530.          IPT1.NUM(1,J)=NUM(1,I)
  531.          IPT1.NUM(2,J)=NUM(2,I)
  532.          IPT1.NUM(3,J)=NUM(3,I)
  533.          IPT1.ICOLOR(J)=ICOLOR(I)
  534.          J=J+1
  535.          IPT1.NUM(1,J)=NUM(1,I)
  536.          IPT1.NUM(2,J)=NUM(3,I)
  537.          IPT1.NUM(3,J)=NUM(4,I)
  538.          IPT1.ICOLOR(J)=ICOLOR(I)
  539.          J=J+1
  540.          IF (J.GT.IPT1.NUM(/2)) GOTO 103
  541.          IPT1.NUM(1,J)=NUM(1,I+1)
  542.          IPT1.NUM(2,J)=NUM(2,I+1)
  543.          IPT1.NUM(3,J)=NUM(4,I+1)
  544.          IPT1.ICOLOR(J)=ICOLOR(I+1)
  545.          J=J+1
  546.          IPT1.NUM(1,J)=NUM(2,I+1)
  547.          IPT1.NUM(2,J)=NUM(3,I+1)
  548.          IPT1.NUM(3,J)=NUM(4,I+1)
  549.          IPT1.ICOLOR(J)=ICOLOR(I+1)
  550.  103  CONTINUE
  551.       SEGSUP MELEME
  552.       MELEME=IPT1
  553.       GOTO 101
  554.  102  CONTINUE
  555.       IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
  556. C    ON FAIT DES QUA8 OU DES TRI6
  557.       NBNN=8
  558.       NBELEM=NUM(/2)
  559.       NBREF=4
  560.       NBSOUS=0
  561.       SEGINI IPT5
  562.       IPT5.ITYPEL=10
  563.       IPT1=LISREF(1)
  564.       IPT2=LISREF(2)
  565.       IPT3=LISREF(3)
  566.       IPT4=LISREF(4)
  567.       IPT5.LISREF(1)=IPT1
  568.       IPT5.LISREF(2)=IPT2
  569.       IPT5.LISREF(3)=IPT3
  570.       IPT5.LISREF(4)=IPT4
  571.       SEGACT IPT1,IPT2,IPT3,IPT4
  572.       DO 105 J=1,NUM(/1)
  573.          JJ=2*J-1
  574.          DO 1051 I=1,NBELEM
  575.             IPT5.NUM(JJ,I)=NUM(J,I)
  576.  1051    CONTINUE
  577.  105  CONTINUE
  578.       DO 135 I=1,NBELEM
  579.          IPT5.ICOLOR(I)=ICOLOR(I)
  580.  135  CONTINUE
  581.       NLIG=IPT1.NUM(/2)
  582.       DO 106 I=1,NLIG
  583.          IPT5.NUM(2,I)=IPT1.NUM(2,I)
  584.          IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I)
  585.  106  CONTINUE
  586.       DPAR=0
  587.       NBPTS=IADR+NCOUCH*NLIG*3
  588.       SEGADJ MCOORD
  589.       DO 107 I=1,NCOUCH
  590.          IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
  591.          IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
  592. C  ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
  593. C  CREATION DES NOEUDS
  594.          DIN=TABPA1(I)
  595.          DPAR=DPAR+DIN
  596.          IF (IOPTG.EQ.1) GOTO 110
  597.          ANG=DPAR*DLONG/RAY
  598.          SI=SIN(ANG)
  599.          CO=COS(ANG)
  600.  110     CONTINUE
  601.          IF (I.EQ.NCOUCH) GOTO 108
  602.          DO 109 J=1,NLIG
  603.             IREF=(IDIM+1)*(IPT1.NUM(2,J)-1)
  604.             IF (IOPTG.NE.1) GOTO 111
  605.             XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+DPAR*XDIS
  606.             XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+DPAR*YDIS
  607.             IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+DPAR
  608.      $           *ZDIS
  609.             GOTO 112
  610.  111        X1=XCOOR(IREF+1)-XPT1
  611.             Y1=XCOOR(IREF+2)-YPT1
  612.             Z1=XCOOR(IREF+3)-ZPT1
  613.             IF (IDIM.EQ.2) Z1=0.D0
  614.             XV=X1*XV1+Y1*YV1+Z1*ZV1
  615.             YV=X1*XV2+Y1*YV2+Z1*ZV2
  616.             ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  617.             XD=XV*CO-YV*SI
  618.             YD=XV*SI+YV*CO
  619.             ZD=ZV
  620.             XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  621.             XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  622.             IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC
  623.      $           +ZPT1
  624.  112        XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  625.             IADR=IADR+1
  626. C  ON MET LE NOEUD DANS LES ELEMENTS
  627.             IPT5.NUM(6,(I-1)*NLIG+J)=IADR
  628.             IPT5.NUM(2,I*NLIG+J)=IADR
  629.  109     CONTINUE
  630.  108     CONTINUE
  631.          IF (NLIG.EQ.1) GOTO 113
  632. C  ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
  633. C  CREATION DES NOEUDS
  634.          EPAR=DPAR-TABPA1(I)*0.5D0
  635.          IF (IOPTG.EQ.1) GOTO 114
  636.          ANG=EPAR*DLONG/RAY
  637.          SI=SIN(ANG)
  638.          CO=COS(ANG)
  639.  114     CONTINUE
  640.          DO 115 J=1,NLIG
  641.             DO 1151 K=1,2
  642.                IF (K.EQ.1.AND.J.EQ.1) GOTO 1151
  643.                IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1151
  644.                IF (ICPR1(K,J).NE.0) GOTO 116
  645.                IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1)
  646.                IF (IOPTG.NE.1) GOTO 117
  647.                XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS
  648.                XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS
  649.                IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR
  650.      $              *ZDIS
  651.                GOTO 118
  652.  117           X1=XCOOR(IREF+1)-XPT1
  653.                Y1=XCOOR(IREF+2)-YPT1
  654.                Z1=XCOOR(IREF+3)-ZPT1
  655.                IF (IDIM.EQ.2) Z1=0
  656.                XV=X1*XV1+Y1*YV1+Z1*ZV1
  657.                YV=X1*XV2+Y1*YV2+Z1*ZV2
  658.                ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  659.                XD=XV*CO-YV*SI
  660.                YD=XV*SI+YV*CO
  661.                ZD=ZV
  662.                XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  663.                XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  664.                IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD
  665.      $              *ZVEC+ZPT1
  666.  118           XCOOR((IADR+1)*(IDIM+1))=DEN1+DECA*EPAR
  667.                IADR=IADR+1
  668.  116           CONTINUE
  669. C  NOEUDS DES ELEM
  670.                IF (ICPR1(K,J).NE.0) GOTO 119
  671.                IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
  672.                GOTO 1151
  673.  119           CONTINUE
  674.                IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR1(K
  675.      $              ,J)-1,2)),(ICPR1(K,J)+1)/2+(I-1)*NLIG)
  676.  1151       CONTINUE
  677.  115     CONTINUE
  678.  113     CONTINUE
  679.  107  CONTINUE
  680.       NBPTS=IADR
  681.       SEGADJ MCOORD
  682.       SEGSUP MELEME
  683.       MELEME=IPT5
  684.       SEGDES IPT1,IPT2,IPT3,IPT4
  685.       IF (KSURF(ILCOUR).NE.6) GOTO 101
  686. C  ON FAIT DES TRI6
  687.       NBNN=6
  688.       NBELEM=2*NUM(/2)
  689.       NBREF=4
  690.       NBSOUS=0
  691.       SEGINI IPT1
  692.       IPT1.ITYPEL=6
  693.       IPT1.LISREF(1)=LISREF(1)
  694.       IPT1.LISREF(2)=LISREF(2)
  695.       IPT1.LISREF(3)=LISREF(3)
  696.       IPT1.LISREF(4)=LISREF(4)
  697.       DPAR=0
  698.       IALT=1
  699.       NBPTS=IADR+NCOUCH*NLIG
  700.       SEGADJ MCOORD
  701.       DO 120 I=1,NCOUCH
  702.          DIN=TABPA1(I)
  703.          DPAR=DPAR+DIN
  704.          EPAR=DPAR-DIN*0.5D0
  705.          IF (IOPTG.EQ.1) GOTO 121
  706.          ANG=EPAR*DLONG/RAY
  707.          SI=SIN(ANG)
  708.          CO=COS(ANG)
  709.  121     CONTINUE
  710.          DO 1201 J=1,NLIG
  711.             INU=(I-1)*NLIG+J
  712.             IALT=3-IALT
  713. C  CREATION DU POINT SUPPLEMENTAIRE
  714.             IREF=(NUM(2,J)-1)*(IDIM+1)
  715.             IF (IOPTG.NE.1) GOTO 122
  716.             XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS
  717.             XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS
  718.             IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR
  719.      $           *ZDIS
  720.             GOTO 123
  721.  122        X1=XCOOR(IREF+1)-XPT1
  722.             Y1=XCOOR(IREF+2)-YPT1
  723.             Z1=XCOOR(IREF+3)-ZPT1
  724.             IF (IDIM.EQ.2) Z1=0.D0
  725.             XV=X1*XV1+Y1*YV1+Z1*ZV1
  726.             YV=X1*XV2+Y1*YV2+Z1*ZV2
  727.             ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  728.             XD=XV*CO-YV*SI
  729.             YD=XV*SI+YV*CO
  730.             ZD=ZV
  731.             XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  732.             XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  733.             IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC
  734.      $           +ZPT1
  735.  123        XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*EPAR
  736.             IADR=IADR+1
  737.             ITR1=2*INU-1
  738.             ITR2=2*INU
  739.             GOTO (124,125),IALT
  740. C  CREATION DES TRIANGLES
  741.  124        IPT1.NUM(1,ITR1)=NUM(1,INU)
  742.             IPT1.NUM(2,ITR1)=NUM(2,INU)
  743.             IPT1.NUM(3,ITR1)=NUM(3,INU)
  744.             IPT1.NUM(5,ITR1)=NUM(7,INU)
  745.             IPT1.NUM(6,ITR1)=NUM(8,INU)
  746.             IPT1.NUM(4,ITR1)=IADR
  747.             IPT1.NUM(1,ITR2)=NUM(3,INU)
  748.             IPT1.NUM(2,ITR2)=NUM(4,INU)
  749.             IPT1.NUM(3,ITR2)=NUM(5,INU)
  750.             IPT1.NUM(4,ITR2)=NUM(6,INU)
  751.             IPT1.NUM(5,ITR2)=NUM(7,INU)
  752.             IPT1.NUM(6,ITR2)=IADR
  753.             IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  754.             IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  755.             GOTO 126
  756.  125        IPT1.NUM(1,ITR1)=NUM(1,INU)
  757.             IPT1.NUM(2,ITR1)=NUM(2,INU)
  758.             IPT1.NUM(3,ITR1)=NUM(3,INU)
  759.             IPT1.NUM(4,ITR1)=NUM(4,INU)
  760.             IPT1.NUM(5,ITR1)=NUM(5,INU)
  761.             IPT1.NUM(6,ITR1)=IADR
  762.             IPT1.NUM(1,ITR2)=NUM(5,INU)
  763.             IPT1.NUM(2,ITR2)=NUM(6,INU)
  764.             IPT1.NUM(3,ITR2)=NUM(7,INU)
  765.             IPT1.NUM(4,ITR2)=NUM(8,INU)
  766.             IPT1.NUM(5,ITR2)=NUM(1,INU)
  767.             IPT1.NUM(6,ITR2)=IADR
  768.             IPT1.ICOLOR(ITR1)=ICOLOR(INU)
  769.             IPT1.ICOLOR(ITR2)=ICOLOR(INU)
  770.             GOTO 126
  771.  126        CONTINUE
  772.  1201    CONTINUE
  773.  120  CONTINUE
  774.       SEGSUP MELEME
  775.       MELEME=IPT1
  776.       GOTO 101
  777.  104  CONTINUE
  778.  101  CONTINUE
  779.       SEGSUP TABPAR,ICPR
  780. C  S'IL Y A LIEU EXAMINER LA DEGENERESCENCE  (ROTATION)
  781.       SEGDES IPT1
  782. **  degsur n'a pas grand sens en 3D et ne marche pas
  783. ***** IF (IOPTG.NE.1) CALL DEGSUR(MELEME,IP1,IP2)
  784.       IF (IFUSE.EQ.0) GOTO 63
  785.       IPT5=IFUSE
  786.       SEGACT IPT5,MELEME
  787.       ltelq=.false.
  788.       CALL FUSE(IPT5,MELEME,IRET,ltelq)
  789.       SEGACT IPT5,MELEME
  790.       IF (ITYPEL.EQ.IPT5.ITYPEL) SEGSUP MELEME
  791.       SEGDES IPT5
  792.       MELEME=IRET
  793.  63   CONTINUE
  794.       CALL ECROBJ('MAILLAGE',MELEME)
  795.       SEGDES MELEME
  796.       RETURN
  797.       END
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  
  804.  
  805.  
  806.  
  807.  
  808.  
  809.  
  810.  
  811.  
  812.  
  813.  
  814.  
  815.  
  816.  
  817.  
  818.  
  819.  
  820.  
  821.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales