Télécharger la plaquette Cast3M


fr en

Télécharger c20227.eso

Retour à la liste

Numérotation des lignes : 

c20227

  1. C C20227    SOURCE    PV        20/03/24    21:15:34     10554          
  2.       SUBROUTINE C20227
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C************************************************************************
  6. C Ce sp transforme des elemnts quadratique d'un type pris
  7. C dans la liste ci-dessous
  8. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  9. C  3    6    10   15   17   24   26
  10. C
  11. C en les éléments correspondant quadratique complet de la liste
  12. C ci-dessous
  13. C
  14. C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
  15. C  3    7    11   33   34   35   36
  16. C************************************************************************
  17. -INC SMELEME
  18. -INC SMCOORD
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMLENTI
  23.       SEGMENT TRAV
  24.       INTEGER IFAC4(4,NBFTM)
  25.       ENDSEGMENT
  26.       SEGMENT TRAV1
  27.       INTEGER NUMF4(9,NBFTM)
  28.       ENDSEGMENT
  29.       SEGMENT SITAF
  30.       INTEGER ITAF(NBFAX,MMMAX)
  31.       ENDSEGMENT
  32.       SEGMENT TRAV2
  33.       INTEGER NUF(6,NBELT)
  34.       ENDSEGMENT
  35.       SEGMENT CARA
  36.       INTEGER KM(6,NBSOU1)
  37.       ENDSEGMENT
  38.  
  39.  
  40.       DIMENSION IAR(3,35),IFR(4,20)
  41.       DATA IAR /1,2,3,3,4,5,5,6,7,7,8,1,
  42.      &          1,9,13,3,10,15,5,11,17,7,12,19,
  43.      &          13,14,15,15,16,17,17,18,19,19,20,13,
  44.      &          1,2,3,3,4,5,5,6,1,1,7,10,3,8,12,5,9,14,
  45.      &          10,11,12,12,13,14,14,15,10,
  46.      &          1,2,3,3,4,5,5,6,1,1,7,10,3,8,10,5,9,10,
  47.      &          1,2,3,3,4,5,5,6,7,7,8,1,1,9,13,3,10,13,
  48.      &          5,11,13,7,12,13/
  49.  
  50.       DATA IFR /1,6,9,5, 2,7,10,6, 3,8,11,7, 4,5,12,8,
  51.      &          1,2,3,4, 9,10,11,12,
  52.      &          1,5,7,4, 2,6,8,5, 3,4,9,6, 1,2,3,0, 7,8,9,0,
  53.      &          1,2,3,0, 1,5,4,0, 2,6,5,0, 3,6,4,0,
  54.      &          1,2,3,4, 1,6,5,0, 2,7,6,0, 3,8,7,0, 4,5,8,0/
  55.  
  56. C Nb de pts par face par type elt
  57.       DIMENSION KNPF(6,7)
  58.       DATA KNPF/1,1,0,0,0,0,
  59.      &          3,3,3,0,0,0,
  60.      &          3,3,3,3,0,0,
  61.      &          8,8,8,8,8,8,
  62.      &          8,8,8,6,6,0,
  63.      &          6,6,6,6,0,0,
  64.      &          8,6,6,6,6,0/
  65.  
  66. C Nb d'arretes par face par type elt
  67.       DIMENSION KNAF(6,7)
  68.       DATA KNAF/0,0,0,0,0,0,
  69.      &          0,0,0,0,0,0,
  70.      &          0,0,0,0,0,0,
  71.      &          4,4,4,4,4,4,
  72.      &          4,4,4,3,3,0,
  73.      &          3,3,3,3,0,0,
  74.      &          4,3,3,3,3,0/
  75.  
  76. C?    DIMENSION I12(35),J12(11)
  77. C?    DATA I12  /1,2,3,4,5,6,7,8,10,12,14,16,19,20,21,22,23,24,25,26,
  78. C?   &           1,2,3,4,5,6,8,10,12,15,16,17,18,19,20/
  79. C?    DATA J12  /11,13,15,17,9,27,
  80. C?   &           9 ,11,13,7 ,21/
  81.  
  82.       DIMENSION INF(8,20)
  83. C CU20
  84.       DATA INF/1,2,3,10,15,14,13,9,  3,4,5,11,17,16,15,10,
  85.      &         5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12,
  86.      &         1,8,7,6,5,4,3,2,      13,14,15,16,17,18,19,20,
  87. C PR15
  88.      &         1,2,3,8 ,12,11,10,7,  3,4,5,9 ,14,13,12,8 ,
  89.      &         5,6,1,7,10,15,14,9 ,  1,2,3,4,5,6,0,0,
  90.      &         10,11,12,13,14,15,0,0,
  91. C TE15
  92.      &  1,2,3,4,5,6,0,0,  1,2,3,8,10,7,0,0,  3,4,5,9,10,8,0,0,
  93.      &  1,6,5,9,10,7,0,0,
  94. C PY15
  95.      &  1,2,3,4,5,6,7,8,  1,2,3,10,13,9,0,0,  3,4,5,11,13,10,0,0,
  96.      &  5,6,7,12,13,11,0,0,  7,8,1,9,13,12,0,0/
  97.  
  98.  
  99.  
  100.  
  101.  
  102.       DIMENSION NUA(12),NUMA(4),XA(3,21),KTA(7,9)
  103.       DATA KTA/3,6,10,15,17,24,26,
  104.      &         3,7,11,33,34,35,36,
  105. C nb de faces
  106.      &         2,3,4 ,6 ,5 ,4 ,5 ,
  107. C nb d'arretes
  108.      &         0,3,4 ,12,9 ,6 ,8,
  109. C Idec
  110.      &         0,0,0 ,0 ,12,21,27,
  111. C Idc3
  112.      &         0,0,0 ,0 ,6 ,11,15,
  113. C Nbnn
  114.      &         3,7,9 ,27,21,15,19,
  115. C NP
  116.      &         3,6,8 ,20,15,10,13,
  117. C IDF
  118.      &         0,0,0 ,0 ,6 ,11,15/
  119.  
  120. C?Numero pt centre N18
  121. C?   &         0,0,0 ,18,14,14,18/
  122. C?Idc2
  123. C?   &         0,0,0 ,0 ,20,35,45,
  124.  
  125. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  126. C  3    6    10   15   17   24   26
  127. C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
  128. C  3    7    11   33   34   35   36
  129.  
  130.  
  131. C     write(6,*)' C20227 dbut '
  132. C*************************************************************
  133.  
  134.       CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  135.       IF(IRET.EQ.0)RETURN
  136.  
  137.       SEGACT MELEME
  138.       NBSOU1=LISOUS(/1)
  139.       IF(NBSOU1.EQ.0)NBSOU1=1
  140.  
  141.       SEGINI CARA
  142.  
  143.       NBELT=0
  144.       IKQF=1
  145.       IK=1
  146.       DO 11 L=1,NBSOU1
  147.          IPT1=MELEME
  148.          IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  149.          SEGACT IPT1
  150.          ITYP=IPT1.ITYPEL
  151.          NBELEM=IPT1.NUM(/2)
  152. * ajout gounand 2016/10/04
  153.          IF (NBELEM.GT.0) THEN
  154.             DO 111 I=1,7
  155.                IF(ITYP.EQ.KTA(I,1))THEN
  156.                   IK=I
  157.                   GO TO 110
  158.                ENDIF
  159.  111        CONTINUE
  160.             IK=0
  161.  110        CONTINUE
  162.  
  163.             DO 112 I=1,7
  164.                IF(ITYP.EQ.KTA(I,2))GO TO 113
  165.  112        CONTINUE
  166. C     write(6,*)' ITYP=',ityp
  167.             IKQF=0
  168.  113        CONTINUE
  169.             NP    =IPT1.NUM(/1)
  170.             IF(IK.GT.1)THEN
  171.                NBELT=NBELT+NBELEM
  172.             ENDIF
  173.             KM(1,L)=NBELEM
  174.             KM(2,L)=IPT1
  175.             KM(3,L)=IK
  176. C     nb d'aretes par element
  177.             KM(4,L)=KTA(IK,4)
  178. C     nb de faces
  179.             KM(5,L)=KTA(IK,3)
  180.          ENDIF
  181.  11   CONTINUE
  182.  
  183.       IF(IDIM.EQ.3)THEN
  184.          ONBN=FLOAT(NBELT)+(3.D0*(FLOAT(NBELT)**(2.D0/3.D0)))
  185.          NBNO=INT(ONBN)
  186.       ELSE
  187.          ONBN=FLOAT(NBELT)+(2.D0*(FLOAT(NBELT)**(0.5D0)))
  188.          NBNO=INT(ONBN)
  189.       ENDIF
  190.  
  191. C     write(6,*)'IKQF=',ikqf,' IK=',ik
  192.       IF(IKQF.NE.0)THEN
  193. C     write(6,*)' C20227 il n y a rien a faire'
  194.          CALL ECROBJ('MAILLAGE',MELEME)
  195.          SEGSUP CARA
  196.          RETURN
  197.       ENDIF
  198.  
  199.       IF(IK.EQ.0)THEN
  200.          CALL ERREUR(29)
  201.          RETURN
  202.       ENDIF
  203.  
  204. C     write(6,*)' C20227 on fait quekchose '
  205.       segact mcoord*mod
  206.       NBPT=NBPTS
  207.       JG=NBPT
  208.       SEGINI MLENTI,MLENT1
  209.  
  210.       NBFAX=4+1
  211.       MMMAX=3*NBELT+300
  212.       SEGINI SITAF
  213.  
  214.       NBFTM=5*NBELT+500
  215.       SEGINI TRAV,TRAV1,TRAV2
  216.  
  217.       SEGACT MELEME
  218.  
  219.       NBFT4=0
  220.       NBAT=0
  221.       NN=0
  222.       MM=0
  223.  
  224.       NK=0
  225.       DO 1 L=1,NBSOU1
  226.          IK=KM(3,L)
  227.          IF (IK.EQ.0) GOTO 1
  228.          IPT1=MELEME
  229.          IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  230.          SEGACT IPT1
  231.          NBELEM=IPT1.NUM(/2)
  232.          NP    =IPT1.NUM(/1)
  233. C     write(6,*)' ITYP,NBELEM=',ITYP,NBELEM
  234.  
  235.          IF(IK.EQ.1)GO TO 1
  236.          IF(IK.EQ.2.OR.IK.EQ.3)THEN
  237.             NK=NK+NBELEM
  238.             GO TO 1
  239.          ENDIF
  240.  
  241.          IDEC=KTA(IK,5)
  242.          IDC3=KTA(IK,6)
  243.          IDF =KTA(IK,9)
  244.          NBA=KTA(IK,4)
  245.          NBF=KTA(IK,3)
  246. C     write(6,*)' NBA,NBF,NPF=',NBA,NBF
  247.  
  248.          DO 2 K=1,NBELEM
  249.             NK=NK+1
  250.  
  251.             DO 5 NA=1,NBA
  252.                N1=IPT1.NUM(IAR(1,NA+IDEC),K)
  253.                N2=IPT1.NUM(IAR(3,NA+IDEC),K)
  254.                NM=IPT1.NUM(IAR(2,NA+IDEC),K)
  255.  
  256.                IF(LECT(NM).EQ.0)THEN
  257. C le milieu n'a pas encore été touché
  258.                   NBAT=NBAT+1
  259.                   LECT(NM)=NBAT
  260.                   NUA(NA)=NBAT
  261.                ELSE
  262.                   NUA(NA)=LECT(NM)
  263.                ENDIF
  264.  
  265.  5          CONTINUE
  266.  
  267.             DO 6 NF=1,NBF
  268. C nb de pts par faces
  269.                NPF=KNPF(NF,IK)
  270. C nb d'arretes par faces
  271.                NAF=KNAF(NF,IK)
  272.  
  273.                DO 61 NFA=1,NAF
  274.                   NUMA(NFA)=NUA(IFR(NFA,NF+IDF))
  275.  61            CONTINUE
  276.  
  277.                CALL ORDOTA(NUMA,NAF)
  278.                IF(MLENT1.LECT(NUMA(1)).EQ.0)THEN
  279. C     l'arrete n'a pas encore été touché
  280.                   NBFT4=NBFT4+1
  281.  
  282.                   IF(NBFT4.GT.NBFTM)THEN
  283. C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  284.                      NBFTM=NBFTM+NBELEM
  285.                      SEGADJ TRAV,TRAV1
  286.                   ENDIF
  287.  
  288.                   NUMF4(9,NBFT4)=NPF
  289.                   DO 621 I=1,NPF
  290.                      NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  291.  621              CONTINUE
  292.                   MM=MM+1
  293.  
  294.                   IF(MM.GT.MMMAX)THEN
  295. C     write(6,*)' Taille ITAF 2eme dime insuffisante MM=',MM
  296.                      MMMAX=MMMAX+NBELEM
  297.                      SEGADJ SITAF
  298.                   ENDIF
  299.  
  300.                   MLENT1.LECT(NUMA(1))=MM
  301.                   ITAF(1,MM)=1
  302.                   ITAF(1+1,MM)=NBFT4
  303. C     write(6,*)' NBFT4=',nbft4,' mm=',mm,' NB=',ITAF(1,mm)
  304.                   NUF(NF,NK)=NBFT4
  305.                   CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  306.                   GO TO 6
  307.                ENDIF
  308.  
  309. C On cherche si la face existe déja dans la table ITAF
  310.                MM1=MLENT1.LECT(NUMA(1))
  311.                NB=ITAF(1,MM1)
  312.                DO 631 II=1,NB
  313.                   I=ITAF(II+1,MM1)
  314.                   IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
  315.      &                 .AND.NUMA(1).EQ.IFAC4(1,I))THEN
  316.                      NUF(NF,NK)=I
  317.                      GO TO 6
  318.                   ENDIF
  319.  631           CONTINUE
  320.  
  321.                IF(NB.LT.(NBFAX-1))THEN
  322. C la face n'existe pas dans la table ITAF qui n'est pas pleine
  323. C On peut donc considerer que la face est nouvelle
  324.                   NBFT4=NBFT4+1
  325.  
  326.                   IF(NBFT4.GT.NBFTM)THEN
  327. C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  328.                      NBFTM=NBFTM+NBELEM
  329. C     write(6,*)' NBFTM=',NBFTM,NBELEM
  330.                      SEGADJ TRAV,TRAV1
  331.                   ENDIF
  332.  
  333.                   NUMF4(9,NBFT4)=NPF
  334.                   DO 622 I=1,NPF
  335.                      NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  336.  622              CONTINUE
  337.                   ITAF(1,MM1)=NB+1
  338.                   ITAF(NB+2,MM1)=NBFT4
  339. C     write(6,*)' NBFT4=',NBFT4,' mm1=',mm1,' NB=',ITAF(1,mm1)
  340.                   NUF(NF,NK)=NBFT4
  341.                   CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  342.                   GO TO 6
  343.                ENDIF
  344.  
  345. C     write(6,*)' Taille ITAF 1ere dime insuffisante NB=',NB
  346.                NBFAX=NBFAX+2
  347.                SEGADJ SITAF
  348. C On fait une recherche parmis toutes les faces existantes
  349.  
  350.  
  351.                IF(NAF.EQ.4)THEN
  352.                   DO 7 I=1,NBFT4
  353.                      IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
  354.      &                    .AND.NUMA(1).EQ.IFAC4(1,I))THEN
  355.                         NUF(NF,NK)=I
  356.                         GO TO 6
  357.                      ENDIF
  358.  7                CONTINUE
  359.                ELSEIF(NAF.EQ.3)THEN
  360.                   DO 71 I=1,NBFT4
  361.                      IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3
  362.      $                    ,I))THEN
  363.                         NUF(NF,NK)=I
  364.                         GO TO 6
  365.                      ENDIF
  366.  71               CONTINUE
  367.                ENDIF
  368.  
  369.  
  370.  64            CONTINUE
  371.                NBFT4=NBFT4+1
  372.  
  373.                IF(NBFT4.GT.NBFTM)THEN
  374. C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  375.                   NBFTM=NBFTM+NBELEM
  376.                   SEGADJ TRAV,TRAV1
  377.                ENDIF
  378.  
  379.                ITAF(1,MM1)=NB+1
  380.                ITAF(NB+2,MM1)=NBFT4
  381.                NUMF4(9,NBFT4)=NPF
  382.                DO 623 I=1,NPF
  383.                   NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  384.  623           CONTINUE
  385.                NUF(NF,NK)=NBFT4
  386.                CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  387.  
  388.  6          CONTINUE
  389.  2       CONTINUE
  390.  1    CONTINUE
  391.  
  392. C**********************************************************
  393.  
  394.       SEGSUP SITAF,MLENTI,MLENT1,TRAV
  395.  
  396. C**********************************************************
  397.  
  398.       SEGACT MELEME
  399.  
  400.       NK=0
  401.       DO 80 L=1,NBSOU1
  402.          IK=KM(3,L)
  403.          IF(IK.EQ.0) GOTO 80
  404.          NBF=KTA(IK,3)
  405.          IF(IK.EQ.1)GO TO 80
  406.  
  407.          IPT1=MELEME
  408.          IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  409.          SEGACT IPT1
  410.  
  411.          NBELEM=KM(1,L)
  412.          NBNN  =KTA(IK,7)
  413.          NP    =KTA(IK,8)
  414.  
  415.          NBSOUS=0
  416.          NBREF=0
  417.          SEGINI IPT2
  418.          KM(2,L)=IPT2
  419.          IPT2.ITYPEL=KTA(IK,2)
  420.          DO K=1,NBELEM
  421.             IPT2.ICOLOR(K)=IPT1.ICOLOR(K)
  422.          ENDDO
  423.  
  424.          IF(IK.GE.4)THEN
  425. C CU27 & PR21
  426.             IDC3=KTA(IK,6)
  427.  
  428.             DO 83 K=1,NBELEM
  429.                NK=NK+1
  430.                DO 8 I=1,NP
  431.                   IPT2.NUM(I,K)=IPT1.NUM(I,K)
  432.  8             CONTINUE
  433.                DO 81 I=1,NBF
  434.                   IPT2.NUM(I+NP,K)=NBPT+NBELT+NUF(I,NK)
  435.  81            CONTINUE
  436.                IPT2.NUM(NBNN,K)=NBPT+NK
  437.  83         CONTINUE
  438.  
  439.          ELSEIF(IK.EQ.2.OR.IK.EQ.3)THEN
  440.             IDC=7
  441.             IF(IK.EQ.3)IDC=9
  442.             NP=NBNN-1
  443.             DO 84 K=1,NBELEM
  444.                NK=NK+1
  445.                DO 88 I=1,NP
  446.                   IPT2.NUM(I,K)=IPT1.NUM(I,K)
  447.  88            CONTINUE
  448.                IPT2.NUM(IDC,K)=NBPT+NK
  449.  84         CONTINUE
  450.  
  451.          ENDIF
  452.  
  453.  80   CONTINUE
  454.  
  455. C     write(6,*)' NUF '
  456. C     DO 783 K=1,NBELT
  457. C     write(6,1011)K,(NUF(i,k),i=1,6)
  458. C783  continue
  459.  
  460. C     do 784 k=1,nbft4
  461. C     write(6,1011)K,(NUMF4(i,k),i=1,8)
  462. C784  continue
  463.  
  464. C     write(6,*)' NBPT=',nbpt
  465. C     write(6,*)' NBAT=',nbat
  466. C     write(6,*)' NBELT=',NBELT,' NBFT4=',nbft4
  467.  
  468.       NBPTS=NBPT+NBELT+NBFT4
  469.       IF(NBPTS.GT.NBPT)SEGADJ MCOORD
  470.  
  471. C************** On calcule les coordonnées des points ***********
  472.  
  473.  
  474.  
  475.       IF(NBFT4.NE.0)THEN
  476.  
  477.          DO 23 J=1,NBFT4
  478.  
  479.             NPF=NUMF4(9,J)
  480.             CALL INITD(XA,63,0.D0)
  481.             DO 21 I=1,NPF
  482.                N1=NUMF4(I,J)
  483.                DO 211 M=1,IDIM
  484.                   XA(M,I)=XCOOR((N1-1)*(IDIM+1)    +M)
  485.  211           CONTINUE
  486.  21         CONTINUE
  487.  
  488.             CALL FFFACE(XA,NPF)
  489.  
  490.             N9=NBPT+NBELT+J
  491.             DO 22 M=1,IDIM
  492.                XCOOR((N9-1)*(IDIM+1)    +M)=XA(M,NPF+1)
  493.  22         CONTINUE
  494.  23      CONTINUE
  495.       ENDIF
  496.  
  497.  
  498. C     write(6,*)' On calcule les coordonnées du pt centre ',NBELT
  499.       IF(NBELT.NE.0)THEN
  500.          SEGACT MELEME
  501.          NK=0
  502.          DO 90 L=1,NBSOU1
  503.             IK=KM(3,L)
  504.             IF(IK.EQ.0.OR.IK.EQ.1) GOTO 90
  505.             IPT1=MELEME
  506.             IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  507.             SEGACT IPT1
  508.  
  509.             NBELEM=KM(1,L)
  510.             NBNN  =KTA(IK,7)
  511.             NP    =KTA(IK,8)
  512.  
  513.             IPT2=KM(2,L)
  514.  
  515.             DO 24 K=1,NBELEM
  516.                NK=NK+1
  517. C????          CALL INITD(XA(1,21),IDIM,0.D0)
  518.                CALL INITD(XA,63,0.D0)
  519.                DO 25 I=1,NP
  520.                   N1=IPT1.NUM(I,K)
  521.                   DO 251 M=1,IDIM
  522.                      XA(M,I)=XCOOR((N1-1)*(IDIM+1)    +M)
  523.                      XA(M,NP+1)=XA(M,NP+1)+(XA(M,I)/FLOAT(NP))
  524.  251              CONTINUE
  525.  25            CONTINUE
  526.                CALL FFFACE(XA,NP)
  527.                N18=NBPT+NK
  528. C     write(6,*)' *** NK=',nk,NBELT,L
  529.                DO 26 M=1,IDIM
  530.                   XCOOR((N18-1)*(IDIM+1)    +M)=XA(M,NP+1)
  531.  26            CONTINUE
  532.  24         CONTINUE
  533.  90      CONTINUE
  534.       ENDIF
  535.  
  536.  
  537. C     write(6,*)' NBPT=',nbpt
  538. C     write(6,*)' NBAT=',nbat
  539. C     do 116 l=1,nbat
  540. C     write(6,1011)L,(itab(i,l),i=1,3)
  541. C116  continue
  542.  
  543. C     write(6,*)' LECT '
  544. C     write(6,1001)(lect(ii),ii=1,nbpt)
  545.  
  546. C     write(6,*)' ITAC NN=',NN
  547. C     do 118 l=1,NN
  548. C      nb=itac(1,l)
  549. C     write(6,1011)L,itac(1,l),(itac(i+1,l),i=1,nb)
  550. C118  continue
  551.  
  552. C     write(6,*)' NBFT4=',nbft4
  553.  
  554. C     do 117 l=1,nbft4
  555. C     write(6,1011)L,(ifac4(i,l),i=1,4)
  556. C117  continue
  557.  
  558. C     write(6,*)' MLENT1.LECT '
  559. C     write(6,1001)(mlent1.lect(ii),ii=1,nbpt)
  560.  
  561. C     write(6,*)' ITAF MM=',MM
  562. C     do 119 l=1,MM
  563. C     nb=itaf(1,l)
  564. C     write(6,1011)L,itaf(1,l),(itaf(i+1,l),i=1,nb)
  565. C119  continue
  566.  
  567.       SEGSUP TRAV1
  568.       NBSOU2=0
  569.       DO L=1,NBSOU1
  570.          IPT9=KM(2,L)
  571.          IF (IPT9.NE.0) THEN 
  572.             NBSOU2=NBSOU2+1
  573.             IF (NBSOU2.EQ.1) IPT3=IPT9
  574.          ENDIF
  575.       ENDDO
  576. *
  577.       IF (NBSOU2.EQ.0) THEN
  578. * Maillage vide de SEG3
  579.          CALL MELVID(3,IPT3)
  580.       ELSEIF(NBSOU2.NE.1)THEN
  581.          NBSOUS=NBSOU2
  582.          NBELEM=0
  583.          NBNN=0
  584.          NBREF=0
  585.          SEGINI IPT3
  586.          IBSOU2=0
  587.          DO 785 L=1,NBSOU1
  588.             IPT9=KM(2,L)
  589.             IF (IPT9.NE.0) THEN
  590.                IBSOU2=IBSOU2+1
  591.                IPT3.LISOUS(IBSOU2)=IPT9
  592.             ENDIF
  593.  785     CONTINUE
  594.       ENDIF
  595.  
  596. C?    SEGACT IPT3
  597. C?    nbref=IPT3.LISREF(/1)
  598. C?    write(6,*)' nbref,meleme=',nbref,meleme
  599. C?    IPT3.LISREF(1)=MELEME
  600.  
  601. C     write(6,*)' C20227 ipt3=',ipt3
  602.       CALL ACTOBJ('MAILLAGE',IPT3,1)
  603.       CALL ECROBJ('MAILLAGE',IPT3)
  604.  
  605.       SEGSUP CARA,TRAV2
  606.  
  607.       RETURN
  608.  1011 FORMAT('L=',I3,4X,15(1X,I5))
  609.  1001 FORMAT(20(1X,I5))
  610.  1002 FORMAT(10(1X,1PE11.4))
  611.       END
  612.  
  613.  
  614.  
  615.  
  616.  

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