Télécharger la plaquette Cast3M


fr en

Télécharger cmacro.eso

Retour à la liste

Numérotation des lignes : 

cmacro

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

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