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