Télécharger la plaquette Cast3M


fr en

Télécharger ccubic.eso

Retour à la liste

Numérotation des lignes : 

ccubic

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

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