Télécharger la plaquette Cast3M


fr en

Télécharger kfce.eso

Retour à la liste

Numérotation des lignes : 

kfce

  1. C KFCE      SOURCE    PV        20/03/24    21:18:33     10554          
  2.       SUBROUTINE KFCE(IQUAD,MELEMQ)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C     Objet : calcule les connectivites faces -> elements (SEG3)
  8. C                                              (Ptc 1   Face   Pc2)
  9. C                     les supports geometriques des faces (POI1)
  10. C
  11. C     Syntaxe : A , B , C , D , E = 'KFCE' GEO  GEO1 <'INCL' TABD> ;
  12. C
  13. C               A : Connectivites elements  -> faces     (ELTFA)  MELAF
  14. C               B : Support geometrique des centres      (CENTRE) MELEM1
  15. C               C : Connectivites faces -> sommets       (FACEP)  MPFD
  16. C               D : Connectivites faces -> elements      (FACEL)  MFD
  17. C               E : Support geometrique des faces        (FACE)   MF1
  18. C
  19. C
  20. C               GEO  : objet maillage
  21. C               GEO1 : support geometrique de l'objet maillage
  22. C
  23. C               INCL : directive indiquant qu'on cherche a inclure les
  24. C                      points crees dans le domaine TABD
  25. C_________________________________________________________________________
  26. C
  27. C NPF = IKAS(5,I,NTYEL)= le nombre de point constituant une face pour
  28. C                        le type d'element NTYEL
  29. C
  30. C
  31. C*************************************************************************
  32.       PARAMETER (NBTYEL=10)
  33.       CHARACTER*8 LTYPEL(NBTYEL),NOM8,TYPE
  34.       DIMENSION   IKAS(5,6,NBTYEL),NPS(4),LTPL(4),MPS(4)
  35.       DIMENSION   LNBFAC(NBTYEL),NBTYF(NBTYEL),LNBSO(25)
  36. C
  37. C CORRESPONDANCE
  38. C  maillage        SEG2  TRI3  QUA4  CUB8  PRI6  PYR5  TET4  TRI6  SEG3  QUA9
  39. C                   |     |     |     |     |     |     |     |     |     |
  40. C                   V     V     V     V     V     V     V     V     V     V
  41. C   faces          SEG2  TRI3  QUA4  PRI6  PYR5  QUA5  TET4  TRI3  SEG2  QUA4
  42. C
  43. C
  44. C ALIAS            seg2  tri3  qua4  pri6  pyr5  qua5  tet4  cub8  tri6 seg3  qua8
  45. C ALIAS numero      2     4     8     16    25    9     23    14    6    3     10
  46.  
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC SMCOORD
  51. -INC SMTABLE
  52.       POINTEUR MTABD.MTABLE,MTBT.MTABLE
  53. -INC SMLENTI
  54. -INC SMELEME
  55.       POINTEUR MFD.MELEME,MF1.MELEME,MELEM1.MELEME
  56.       POINTEUR MPFD.MELEME,MELAF.MELEME
  57.       POINTEUR MELEMC.MELEME,MELEF1.MELEME
  58.       POINTEUR MELES1.MELEME,MELEMQ.MELEME
  59.       POINTEUR MELEM0.MELEME
  60. -INC CCGEOME
  61.  
  62.       SEGMENT TRAV
  63.       INTEGER ITRAV(NBFA,4)
  64.       ENDSEGMENT
  65.  
  66.       CHARACTER*4 LISMO(1)
  67.       PARAMETER (NTB=1)
  68.       DIMENSION   KTAB(NTB)
  69.       CHARACTER*8 LTAB(NTB)
  70.       DATA LTYPEL/'SEG2    ','TRI3    ','QUA4    ','CUB8    ',
  71.      &     'PRI6    ','PYR5    ','TET4    ',
  72.      &     'TRI6    ','SEG3    ','QUA8    '/
  73.       DATA LNBFAC/  2   ,  3   ,  4   ,  6   ,  5   ,  5   ,  4   ,
  74.      &     3   ,  2   ,  4   /
  75.       DATA  NBTYF/  2   ,  4   ,  8   , 16   ,  25  ,  9   ,  23  ,
  76.      &     4   ,  2   ,  8   /
  77. C LNBSO pointe sur la ligne de IKAS en fct du type d'element (position
  78. C dans LNBSO)
  79.       DATA LNBSO  /0 ,1 ,9 ,2 ,0 ,8 ,0 ,3 ,
  80.      &     0 ,10,0 ,0 ,0 ,4 ,0 ,5 ,
  81.      &     0 ,0 ,0 ,0 ,0 ,0 ,7 ,0 ,6/
  82.       DATA IKAS/
  83.      &     1,0,0,0,1,2,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  84.      &     1,2,0,0,2,2,3,0,0,2,3,1,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  85.      &     1,2,0,0,2,2,3,0,0,2,3,4,0,0,2,4,1,0,0,2,0,0,0,0,0,0,0,0,0,0,
  86.      &     1,2,3,4,4,5,6,7,8,4,1,2,6,5,4,2,3,7,6,4,3,4,8,7,4,4,1,5,8,4,
  87.      &     1,2,3,0,3,4,5,6,0,3,1,2,5,4,4,2,3,6,5,4,3,1,4,6,4,0,0,0,0,0,
  88.      &     1,2,3,4,4,1,2,5,0,3,2,3,5,0,3,3,4,5,0,3,4,1,5,0,3,0,0,0,0,0,
  89.      &     1,2,4,0,3,1,2,3,0,3,4,2,3,0,3,1,4,3,0,3,0,0,0,0,0,0,0,0,0,0,
  90.      &     1,3,0,0,2,3,5,0,0,2,5,1,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  91.      &     1,0,0,0,1,3,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  92.      &     1,3,0,0,2,3,5,0,0,2,5,7,0,0,2,7,1,0,0,2,0,0,0,0,0,0,0,0,0,0/
  93.       DATA LTPL /1,2,4,8/
  94.       DATA LISMO /'INCL'/
  95.       DATA LTAB /'DOMAINE '/
  96.  
  97. C***
  98.       CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  99.       MELEM0=MELEME
  100.       IF(IRET.EQ.0)GO TO 90
  101.       CALL LIRREE(XVAL,0,IXV)
  102.       XVAL=ABS(XVAL)
  103.  
  104.       MTABD=0
  105.       KINC=0
  106.       CALL LIRMOT(LISMO,1,IP,0)
  107.       IF(IP.NE.0)THEN
  108.          KINC=1
  109.          NTO=1
  110.          CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  111.          IF(IRET.EQ.0)RETURN
  112.          CALL LIRREE(XVAL,1,IXV)
  113.          IF(IRET.EQ.0)RETURN
  114.          XVAL=ABS(XVAL)
  115.          MTABD=KTAB(1)
  116.          TYPE=' '
  117.          CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  118.          IF(TYPE.NE.'MAILLAGE')RETURN
  119.          TYPE=' '
  120.          CALL ACMO(MTABD,'FACE',TYPE,MELEF1)
  121.          IF(TYPE.NE.'MAILLAGE')RETURN
  122.          TYPE=' '
  123.          CALL ACMO(MTABD,'SOMMET',TYPE,MELES1)
  124.          IF(TYPE.NE.'MAILLAGE')RETURN
  125.       ENDIF
  126.  
  127.  
  128.       SEGACT MELEME
  129.       NBSOUS=LISOUS(/1)
  130.  
  131.       IF(NBSOUS.NE.0)THEN
  132.          NBNN=0
  133.          NBELEM=0
  134.          NBREF=0
  135.          SEGINI MELAF
  136.       ELSE
  137.          NBSOUS=1
  138.       ENDIF
  139.  
  140.       NBFA=0
  141.       IELIM=0
  142.       NBS=NBSOUS
  143.  
  144.       DO 1 L=1,NBS
  145.          IF(NBS.NE.1)THEN
  146.             IPT1=LISOUS(L)
  147.             SEGACT IPT1
  148.          ELSE
  149.             IPT1=MELEME
  150.          ENDIF
  151.          NOM8=NOMS(IPT1.ITYPEL)//'    '
  152.          CALL OPTLI(IP,LTYPEL,NOM8,NBTYEL)
  153. C     write(6,*)' NOM8,IP=',NOM8,IP
  154.          IF(IP.EQ.0)THEN
  155.             WRITE(6,*)' On ne sait rien faire pour cet element ',NOM8
  156.             GO TO 90
  157.          ENDIF
  158.          IF((IDIM.EQ.2.AND.IP.EQ.1).OR.
  159.      $        (IDIM.EQ.3.AND.IP.LE.3)) IELIM=1
  160.  
  161.          NBNN=LNBFAC(IP)
  162.          NBELEM=IPT1.NUM(/2)
  163.          NBFA=NBFA+NBELEM*NBNN
  164.          NBSOUS=0
  165.          NBREF=0
  166.          SEGINI IPT2
  167.          IPT2.ITYPEL=NBTYF(IP)
  168.          IF(NBS.NE.1) THEN
  169.             MELAF.LISOUS(L)=IPT2
  170. CG    Pas besoin de désactiver MELAF, MELEME, IPT1, IPT2
  171. CG            SEGDES IPT2
  172. CG            SEGDES IPT1
  173.          ELSE
  174.             MELAF=IPT2
  175.          ENDIF
  176.  1    CONTINUE
  177. CG      SEGDES MELEME
  178. CG      SEGDES MELAF
  179. C     write(6,*)' Nombre de face total =',NBFA
  180.  
  181.       IDIM1=IDIM+1
  182. CG    Pas besoin d'activer MELAF, MELEME, IPT1, IPT2
  183. CG      SEGACT MELEME,MELAF*MOD
  184.       DO 50 L=1,NBS
  185.          IF(NBS.NE.1)THEN
  186.             IPT1=LISOUS(L)
  187.             IPT2=MELAF.LISOUS(L)
  188. CG            SEGACT IPT1
  189. CG            SEGACT IPT2*MOD
  190.          ELSE
  191.             IPT1=MELEME
  192.             IPT2=MELAF
  193.          ENDIF
  194.          NOM8=NOMS(IPT1.ITYPEL)//'    '
  195.          CALL OPTLI(IP,LTYPEL,NOM8,NBTYEL)
  196.          IF(IP.GE.8.AND.IP.LE.10)THEN
  197.             IQUAD=1
  198.          ELSE
  199.             IQUAD=0
  200.          ENDIF
  201.  
  202.          NBFAC=LNBFAC(IP)
  203.          NEL=IPT1.NUM(/2)
  204.          NP=IPT1.NUM(/1)
  205.  
  206. C ici on reserve la place pour les faces (ne concerne pas les TRI6...)
  207.          NELN=0
  208.          IF(IQUAD.EQ.0)THEN
  209.             NELN=NEL*NBFAC
  210. C     write(6,*)' NBFAC=',NBFAC,' IP=',IP,' NP=',NP,' NF=',NF
  211.             segact mcoord*mod
  212.             NBPTI=nbpts
  213.             KF=NBPTI
  214.             NBPTS=NBPTI+NELN
  215.             SEGADJ MCOORD
  216.          ENDIF
  217.  
  218.          DO 52 I=1,NBFAC
  219.             NPF=IKAS(5,I,IP)
  220.             I1=IKAS(1,I,IP)
  221.             I2=IKAS(2,I,IP)
  222.             I3=IKAS(3,I,IP)
  223.             I4=IKAS(4,I,IP)
  224.  
  225.             GO TO (631,632,633,634),NPF
  226.  
  227.  631        CONTINUE
  228.  
  229.             IF(IDIM.EQ.2)THEN
  230. C     write(6,*)' Cas Segment la face est un poi1 '
  231.  
  232.                IF(IQUAD.EQ.0)THEN
  233.                   DO 851 K=1,NEL
  234.                      KF1=KF
  235.                      KF=KF+1
  236.                      IPT2.NUM(I,K)=KF
  237.                      N1=IPT1.NUM(I1,K)
  238.                      N11=N1-1
  239.                      MD1=N11*IDIM1+1
  240.                      MD2=N11*IDIM1+2
  241.                      MG1=KF1*IDIM1+1
  242.                      MG2=KF1*IDIM1+2
  243.                      XCOOR(MG1)=XCOOR(MD1)
  244.                      XCOOR(MG2)=XCOOR(MD2)
  245.                      XCOOR(KF*IDIM1)=XCOOR(N1*IDIM1)
  246.  851              CONTINUE
  247.                ELSE
  248.                   DO 751 K=1,NEL
  249.                      IPT2.NUM(I,K)=IPT1.NUM(I1,K)
  250.  751              CONTINUE
  251.                ENDIF
  252.  
  253.             ELSE
  254.  
  255.                DO 951 K=1,NEL
  256.                   KF1=KF
  257.                   KF=KF+1
  258.                   IPT2.NUM(I,K)=KF
  259.                   N1=IPT1.NUM(I1,K)
  260.                   N11=N1-1
  261.                   MD1=N11*IDIM1+1
  262.                   MD2=N11*IDIM1+2
  263.                   MD3=N11*IDIM1+3
  264.                   MG1=KF1*IDIM1+1
  265.                   MG2=KF1*IDIM1+2
  266.                   MG3=KF1*IDIM1+3
  267.                   XCOOR(MG1)=XCOOR(MD1)
  268.                   XCOOR(MG2)=XCOOR(MD2)
  269.                   XCOOR(MG3)=XCOOR(MD3)
  270.                   XCOOR(KF*IDIM1)=XCOOR(N1*IDIM1)
  271.  951           CONTINUE
  272.             ENDIF
  273.  
  274.             GO TO 640
  275.  
  276.  632        CONTINUE
  277.  
  278.             IF(IDIM.EQ.2)THEN
  279. C     write(6,*)' Cas Triangle ou quadrangle la face est un seg2 '
  280.  
  281.                IF(IQUAD.EQ.0)THEN
  282.                   DO 852 K=1,NEL
  283.                      KF1=KF
  284.                      KF=KF+1
  285.                      IPT2.NUM(I,K)=KF
  286.                      N1=IPT1.NUM(I1,K)
  287.                      N2=IPT1.NUM(I2,K)
  288.                      MG1=KF1*IDIM1+1
  289.                      MG2=KF1*IDIM1+2
  290.                      XCOOR(MG1)=
  291.      &                    (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1))
  292.      $                    /2.D0
  293.                      XCOOR(MG2)=
  294.      &                    (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2))
  295.      $                    /2.D0
  296.                      XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1))/2
  297.      $                    .D0
  298. C     write(6,*)' KF=',KF,XCOOR(MG1),XCOOR(MG2)
  299.  852              CONTINUE
  300.                ELSE
  301. C       write(6,*)' I1,I=',i1,i
  302.                   DO 752 K=1,NEL
  303.                      IPT2.NUM(I,K)=IPT1.NUM(I1+1,K)
  304.  752              CONTINUE
  305.                ENDIF
  306.  
  307.             ELSE
  308.  
  309.                DO 952 K=1,NEL
  310.                   KF1=KF
  311.                   KF=KF+1
  312.                   IPT2.NUM(I,K)=KF
  313.                   N1=IPT1.NUM(I1,K)
  314.                   N2=IPT1.NUM(I2,K)
  315.                   MG1=KF1*IDIM1+1
  316.                   MG2=KF1*IDIM1+2
  317.                   MG3=KF1*IDIM1+3
  318.                   XCOOR(MG1)=
  319.      &                 (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1))/2
  320.      $                 .D0
  321.                   XCOOR(MG2)=
  322.      &                 (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2))/2
  323.      $                 .D0
  324.                   XCOOR(MG3)=
  325.      &                 (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3))/2
  326.      $                 .D0
  327.                   XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1))/2.D0
  328.  952           CONTINUE
  329.             ENDIF
  330.  
  331.             GO TO 640
  332.  
  333.  633        CONTINUE
  334.             DO 853 K=1,NEL
  335.                KF1=KF
  336.                KF=KF+1
  337.                IPT2.NUM(I,K)=KF
  338.                N1=IPT1.NUM(I1,K)
  339.                N2=IPT1.NUM(I2,K)
  340.                N3=IPT1.NUM(I3,K)
  341.                MG1=KF1*IDIM1+1
  342.                MG2=MG1+1
  343.                MG3=MG1+2
  344.                XCOOR(MG1)=
  345.      &              (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1)
  346.      &              +XCOOR((N3-1)*IDIM1+1))/3.D0
  347.                XCOOR(MG2)=
  348.      &              (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2)
  349.      &              +XCOOR((N3-1)*IDIM1+2))/3.D0
  350.                XCOOR(MG3)=
  351.      &              (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3)
  352.      &              +XCOOR((N3-1)*IDIM1+3))/3.D0
  353.                XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1)
  354.      &              +XCOOR(N3*IDIM1))/3.D0
  355.  853        CONTINUE
  356.  
  357.             GO TO 640
  358.  
  359.  634        CONTINUE
  360.             DO 854 K=1,NEL
  361.                KF1=KF
  362.                KF=KF+1
  363.                IPT2.NUM(I,K)=KF
  364.                N1=IPT1.NUM(I1,K)
  365.                N2=IPT1.NUM(I2,K)
  366.                N3=IPT1.NUM(I3,K)
  367.                N4=IPT1.NUM(I4,K)
  368.                MG1=KF1*IDIM1+1
  369.                MG2=MG1+1
  370.                MG3=MG1+2
  371.                XCOOR(MG1)=
  372.      &              (XCOOR((N1-1)*IDIM1+1)+XCOOR((N2-1)*IDIM1+1)
  373.      &              +XCOOR((N3-1)*IDIM1+1)+XCOOR((N4-1)*IDIM1+1))/4.D0
  374.                XCOOR(MG2)=
  375.      &              (XCOOR((N1-1)*IDIM1+2)+XCOOR((N2-1)*IDIM1+2)
  376.      &              +XCOOR((N3-1)*IDIM1+2)+XCOOR((N4-1)*IDIM1+2))/4.D0
  377.                XCOOR(MG3)=
  378.      &              (XCOOR((N1-1)*IDIM1+3)+XCOOR((N2-1)*IDIM1+3)
  379.      &              +XCOOR((N3-1)*IDIM1+3)+XCOOR((N4-1)*IDIM1+3))/4.D0
  380.                XCOOR(KF*IDIM1)=(XCOOR(N1*IDIM1)+XCOOR(N2*IDIM1)
  381.      &              +XCOOR(N3*IDIM1)+XCOOR(N4*IDIM1))/4.D0
  382.  854        CONTINUE
  383.  
  384.  640        CONTINUE
  385.  
  386.  52      CONTINUE
  387. CG Normalement, il n'y a pas besoin de désactiver MELAF et MELEME
  388. CG vu qu'ils sont réutilisés juste après
  389. CG         IF(NBS.NE.1)THEN
  390. CG            SEGDES IPT2
  391. CG            SEGDES IPT1
  392. CG         ENDIF
  393.  50   CONTINUE
  394. CG      SEGDES MELAF
  395. CG      SEGDES MELEME
  396.  
  397.       CALL CRTABL(MTBT)
  398.       CALL NOMOBJ('TABLE','tabletmp',MTBT)
  399.  
  400.       CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  401.       IF(IXV.EQ.0)XVAL=XCOOR(KF*IDIM1)*(1.D-4)+1.D-8
  402.       CALL ECROBJ('MAILLAGE',MELAF)
  403.       WRITE(6,1951)
  404.  1951 FORMAT(1H+,' Creation des points face ')
  405.       CALL ECRREE(XVAL)
  406.       CALL PRELIM(0)
  407.       CALL LIROBJ('MAILLAGE',MELAF,1,IRET)
  408.       CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  409.       CALL ECRCHA('POI1')
  410.       CALL ECROBJ('MAILLAGE',MELAF)
  411.       CALL PRCHAN
  412.       CALL LIROBJ('MAILLAGE',MF1,1,IRET)
  413.       IF(IRET.EQ.0)RETURN
  414.       CALL ECMO(MTBT,'MF1','MAILLAGE',MF1)
  415.       CALL KNBEL(MF1,NBFA)
  416.  
  417. C Ici On cree les points centre
  418. C     write(6,*)' Ici On cree les points centre'
  419.  
  420.       CALL ECROBJ('MAILLAGE',MELEM0)
  421.       CALL CRECTR
  422.       CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  423.       IF(IRET.EQ.0)RETURN
  424.  
  425.       IF(IQUAD.EQ.1)THEN
  426.  
  427. C Cas des éléments quadratiques on cree des TRI7,QUA9...
  428. C     write(6,*)' Cas des éléments quadratiques'
  429.  
  430.          SEGACT MELEME,MELEM1
  431.          NBSOUS=LISOUS(/1)
  432.          NBSOU2=NBSOUS
  433.          IF(NBSOUS.EQ.0)NBSOU2=1
  434.          KP=0
  435.          DO 1880 L=1,NBSOU2
  436.             IPT1=MELEME
  437.             IF(NBSOU2.NE.1)IPT1=LISOUS(L)
  438.             SEGACT IPT1
  439.             NBNN=IPT1.NUM(/1)+1
  440.             IF(IPT1.ITYPEL.EQ.3)NBNN=IPT1.NUM(/1)
  441.             NBELEM=IPT1.NUM(/2)
  442.             NBREF=0
  443.             IF(L.EQ.1.AND.NBSOU2.EQ.1)THEN
  444.                SEGINI MELEMQ
  445.                IPT2=MELEMQ
  446.             ELSEIF(L.EQ.1.AND.NBSOU2.NE.1)THEN
  447.                NBNN=0
  448.                NBELEM=0
  449.                NBREF=0
  450.                SEGINI MELEMQ
  451.                NBNN=IPT1.NUM(/1)+1
  452.                IF(IPT1.ITYPEL.EQ.3)NBNN=IPT1.NUM(/1)
  453.                NBELEM=IPT1.NUM(/2)
  454.                NBSOUS=0
  455.                NBREF=0
  456.                SEGINI IPT2
  457.                MELEMQ.LISOUS(1)=IPT2
  458.                NBSOUS=NBSOU2
  459.             ELSE
  460.                NBSOUS=0
  461.                NBREF=0
  462.                SEGINI IPT2
  463.                MELEMQ.LISOUS(L)=IPT2
  464.                NBSOUS=NBSOU2
  465.             ENDIF
  466.  
  467.             IF(IPT1.ITYPEL.EQ.6)THEN
  468.                IPT2.ITYPEL=7
  469.                DO 1883 K=1,NBELEM
  470.                   KP=KP+1
  471.                   DO 1882 I=1,NBNN-1
  472.                      IPT2.NUM(I,K)=IPT1.NUM(I,K)
  473.  1882             CONTINUE
  474.                   IPT2.NUM(NBNN,K)=MELEM1.NUM(1,KP)
  475.  1883          CONTINUE
  476.             ELSEIF(IPT1.ITYPEL.EQ.3)THEN
  477.                IPT2.ITYPEL=3
  478.                DO 1885 K=1,NBELEM
  479.                   DO 18851 I=1,NBNN
  480.                      IPT2.NUM(I,K)=IPT1.NUM(I,K)
  481. 18851             CONTINUE
  482.  1885          CONTINUE
  483.             ELSEIF(IPT1.ITYPEL.EQ.10)THEN
  484.                IPT2.ITYPEL=11
  485.                DO 1886 K=1,NBELEM
  486.                   KP=KP+1
  487.                   DO 1887 I=1,NBNN-1
  488.                      IPT2.NUM(I,K)=IPT1.NUM(I,K)
  489.  1887             CONTINUE
  490.                   IPT2.NUM(NBNN,K)=MELEM1.NUM(1,KP)
  491.  1886          CONTINUE
  492.             ELSE
  493.                WRITE(6,*)' Type d''élément non encore prévu'
  494.             ENDIF
  495.  
  496.  1880    CONTINUE
  497.          CALL ECMO(MTBT,'MELEMQ','MAILLAGE',MELEMQ)
  498.       ENDIF
  499.  
  500.  
  501. C<<<<<<<<<<<<<
  502.       CALL ECMO(MTBT,'MELEM1','MAILLAGE',MELEM1)
  503. C     CALL ECMO(MTBT,'MELEM0','MAILLAGE',MELEM0)
  504. C     CALL ECMO(MTBT,'MELAF','MAILLAGE',MELAF)
  505.  
  506.       IF(IELIM.NE.0)THEN
  507.  
  508.          WRITE(6,1952)
  509.  1952    FORMAT(1H+,' Elimination entre points centre et points face')
  510.          CALL ECROBJ('MAILLAGE',MELEM1)
  511.          CALL ECRREE(XVAL)
  512.          CALL ECROBJ('MAILLAGE',MELAF)
  513.          CALL PRELIM(0)
  514.          CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  515.          IF(IRET.EQ.0)RETURN
  516.  
  517.          WRITE(6,1954)
  518.  1954    FORMAT(1H+,' Elimination entre points face et points sommet')
  519.          CALL ECROBJ('MAILLAGE',MELEM0)
  520.          CALL ECRREE(XVAL)
  521.          CALL ECROBJ('MAILLAGE',MELAF)
  522.          CALL PRELIM(0)
  523.          CALL LIROBJ('MAILLAGE',MELEM0,1,IRET)
  524.          IF(IRET.EQ.0)RETURN
  525.  
  526.       ENDIF
  527.  
  528. C Ici On cree les connectivites FACEL (SEG3)
  529. C     -> In KRIPAD : SEGINI MLENTI
  530. C     -> In KRIPAD : SEGACT MF1
  531.       CALL KRIPAD(MF1,MLENTI)
  532.       SEGDES MF1
  533.       SEGACT MELEM1
  534.  
  535.       NBNN=3
  536.       NBELEM=NBFA
  537.       NBSOUS=0
  538.       NBREF=0
  539.       SEGINI MFD
  540.       MFD.ITYPEL=3
  541.       SEGACT MELAF
  542.       NBSOUS=MELAF.LISOUS(/1)
  543.       IF(NBSOUS.EQ.0)NBSOUS=1
  544.       NK=0
  545.       DO 784 NS=1,NBSOUS
  546.          IF(NBSOUS.NE.1)THEN
  547.             MELEME=MELAF.LISOUS(NS)
  548.             SEGACT MELEME
  549.          ELSE
  550.             MELEME=MELAF
  551.          ENDIF
  552.          NEL=NUM(/2)
  553.          NP =NUM(/1)
  554.          DO 783 K=1,NEL
  555.             NK=NK+1
  556.             NNK=MELEM1.NUM(1,NK)
  557.             DO 782 I=1,NP
  558.                NUF=NUM(I,K)
  559.                NUF1=LECT(NUF)
  560.                MFD.NUM(1,NUF1)=NNK
  561.                MFD.NUM(2,NUF1)=NUF
  562.  782        CONTINUE
  563.  783     CONTINUE
  564. CG Pas besoin de désactiver
  565. CG         IF(NBSOUS.NE.1)SEGDES MELEME
  566. CG         SEGDES MELEME
  567.  784  CONTINUE
  568.  
  569.       NK=NK+1
  570.       DO 785 NS=NBSOUS,1,-1
  571.          IF(NBSOUS.NE.1)THEN
  572.             MELEME=MELAF.LISOUS(NS)
  573. CG Pas besoin de réactiver
  574. CG            SEGACT MELEME
  575.          ELSE
  576.             MELEME=MELAF
  577.          ENDIF
  578.          NEL=NUM(/2)
  579.          NP =NUM(/1)
  580.          DO 786 K=NEL,1,-1
  581.             NK=NK-1
  582.             NNK=MELEM1.NUM(1,NK)
  583.             DO 787 I=1,NP
  584.                NUF=NUM(I,K)
  585.                NUF1=LECT(NUF)
  586.                MFD.NUM(3,NUF1)=NNK
  587.  787        CONTINUE
  588.  786     CONTINUE
  589. CG    Pas besoin de désactiver mais après, il s'appelle IPT1 !
  590. CG         IF(NBSOUS.NE.1)SEGDES MELEME
  591.  785  CONTINUE
  592. CG      SEGDES MELAF
  593.       SEGDES MFD
  594.       SEGDES MELEM1
  595.  
  596.  
  597. C ici on cree les connectivites face --> sommet
  598.  
  599. CG    Sous-entendu : NBFA=nb_éléments(MF1)
  600.       SEGINI TRAV
  601.       SEGACT MELEM0
  602. CG      SEGACT MELAF
  603.       NBSOUS=MELAF.LISOUS(/1)
  604.       IF(NBSOUS.EQ.0)NBSOUS=1
  605.       DO 338 L=1,NBSOUS
  606.          IF(NBSOUS.NE.1)THEN
  607.             IPT1=MELAF.LISOUS(L)
  608.             IPT2=MELEM0.LISOUS(L)
  609. CG    Déja activé plus haut
  610. CG            SEGACT IPT1
  611.             SEGACT IPT2
  612.          ELSE
  613.             IPT1=MELAF
  614.             IPT2=MELEM0
  615.          ENDIF
  616.          NP =IPT1.NUM(/1)
  617.          NEL=IPT1.NUM(/2)
  618.          IP=LNBSO(IPT2.ITYPEL)
  619.          DO 339 K=1,NEL
  620.             DO 3391 I=1,NP
  621.                NUF=IPT1.NUM(I,K)
  622.                NUF=LECT(NUF)
  623.                ITRAV(NUF,1)=IPT2
  624.                ITRAV(NUF,2)=IP
  625.                ITRAV(NUF,3)=I
  626.                ITRAV(NUF,4)=K
  627.  3391       CONTINUE
  628.  339     CONTINUE
  629.          IF(NBSOUS.NE.1)SEGDES IPT1
  630.  338  CONTINUE
  631.       SEGDES MELAF
  632.       SEGSUP MLENTI
  633.  
  634. C     write(6,*)' Fin premiere partie '
  635.       CALL INITI(NPS,4,0)
  636.       DO 340 L=1,NBFA
  637.          IP=ITRAV(L,2)
  638.          I =ITRAV(L,3)
  639.          NBS=IKAS(5,I,IP)
  640. C     write(6,*)' IP,I,nbs=',IP,I,nbs
  641.          NPS(NBS)=NPS(NBS)+1
  642.  340  CONTINUE
  643. C     write(6,*)' NPS=',NPS
  644.       NT=0
  645.       DO 341 I=1,4
  646.          IF(NPS(I).NE.0)THEN
  647.             NT=NT+1
  648.             IT=I
  649.          ENDIF
  650.  341  CONTINUE
  651.       NBREF=0
  652.       IF(NT.EQ.1)THEN
  653.          NBSOUS=0
  654.          NBELEM=NPS(IT)
  655.          NBNN=IT
  656.          SEGINI MELEME
  657.          ITYPEL=LTPL(IT)
  658.          NPS(IT)=MELEME
  659.       ELSE
  660.          NBSOUS=NT
  661.          NBELEM=0
  662.          NBNN=0
  663.          SEGINI MELEME
  664.          JJ=0
  665.          DO 342 J=1,4
  666.             IF(NPS(J).EQ.0)GO TO 342
  667.             JJ=JJ+1
  668.             NBSOUS=0
  669.             NBREF=0
  670.             NBNN=J
  671.             NBELEM=NPS(J)
  672.             SEGINI IPT3
  673.             LISOUS(JJ)=IPT3
  674.             IPT3.ITYPEL=LTPL(J)
  675.             NPS(J)=IPT3
  676. C     write(6,*)' ipt3=',ipt3,' j=',j,' jj=',jj
  677.  342     CONTINUE
  678.       ENDIF
  679.       MPFD=MELEME
  680. C     write(6,*)' Fin deuxieme partie MPFD=',MPFD
  681.  
  682.       CALL INITI(MPS,4,0)
  683.  
  684.       DO 343 L=1,NBFA
  685.          IPT2=ITRAV(L,1)
  686.          IP=ITRAV(L,2)
  687.          I =ITRAV(L,3)
  688.          K =ITRAV(L,4)
  689.          NBS=IKAS(5,I,IP)
  690.          IPT3=NPS(NBS)
  691.          MPS(NBS)=MPS(NBS)+1
  692.          KK=MPS(NBS)
  693.          DO 344 J=1,NBS
  694.             JJ=IKAS(J,I,IP)
  695. C     write(6,*)'j,kk=',j,kk,' jj,k',jj,k,' nbs=',nbs
  696.             IPT3.NUM(J,KK)=IPT2.NUM(JJ,K)
  697.  344     CONTINUE
  698.  343  CONTINUE
  699.  
  700.       IF(MPFD.LISOUS(/1).NE.0)THEN
  701.          NSO=MPFD.LISOUS(/1)
  702.          DO 765 I=1,NSO
  703.             IPT3=MPFD.LISOUS(I)
  704.             SEGDES IPT3
  705.  765     CONTINUE
  706.       ENDIF
  707.       SEGDES MPFD
  708.  
  709.       IF(MELEM0.LISOUS(/1).NE.0)THEN
  710.          NSO=MELEM0.LISOUS(/1)
  711.          DO 766 I=1,NSO
  712.             IPT3=MELEM0.LISOUS(I)
  713.             SEGDES IPT3
  714.  766     CONTINUE
  715.          SEGDES MELEM0
  716.       ENDIF
  717.  
  718.       SEGSUP TRAV
  719.       IF(KINC.EQ.1)THEN
  720.          WRITE(6,1953)
  721.  1953    FORMAT(1H+
  722.      $        ,' Elimination avec les points d''un autre domaine')
  723.          CALL ECMO(MTBT,'MFD','MAILLAGE',MFD)
  724.          CALL ECMO(MTBT,'MPFD','MAILLAGE',MPFD)
  725.          CALL ECROBJ('MAILLAGE',MELEF1)
  726.          CALL ECROBJ('MAILLAGE',MELEMC)
  727.          CALL PRFUSE
  728.          CALL ECROBJ('MAILLAGE',MELES1)
  729.          CALL PRFUSE
  730.          CALL LIROBJ('MAILLAGE',IPT1,1,IRET)
  731.          IF(IRET.EQ.0)RETURN
  732.          CALL ECMO(MTBT,'IPT1','MAILLAGE',IPT1)
  733.          CALL ECROBJ('MAILLAGE',MF1)
  734.          CALL ECROBJ('MAILLAGE',MELEM1)
  735.          CALL PRFUSE
  736.          CALL LIROBJ('MAILLAGE',IPT2,1,IRET)
  737.          IF(IRET.EQ.0)RETURN
  738.          CALL ECMO(MTBT,'IPT2','MAILLAGE',IPT2)
  739.          CALL ECROBJ('MAILLAGE',IPT1)
  740.          CALL ECRREE(XVAL)
  741.          CALL ECROBJ('MAILLAGE',IPT2)
  742. C     write(6,*)' Avant prelim ipt1=',ipt1,' ipt2',ipt2
  743.          CALL PRELIM(0)
  744.          CALL LIROBJ('MAILLAGE',IPT3,1,IRET)
  745. C     write(6,*)' retour PRELIM IPT3=',IPT3
  746.          SEGSUP IPT1
  747.          SEGSUP IPT2
  748. C         SEGSUP IPT3
  749.       ENDIF
  750.       SEGSUP MTBT
  751.       CALL ECROBJ('MAILLAGE',MF1)
  752.       CALL ECROBJ('MAILLAGE',MFD)
  753.       CALL ECROBJ('MAILLAGE',MPFD)
  754.       CALL ECROBJ('MAILLAGE',MELEM1)
  755.       CALL ECROBJ('MAILLAGE',MELAF)
  756.  
  757.       RETURN
  758.  
  759.  90   CONTINUE
  760.       WRITE(6,*)' Retour anormal de KFCE '
  761.       RETURN
  762.       END
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.  
  771.  
  772.  
  773.  

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