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

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