Télécharger la plaquette Cast3M


fr en

Télécharger kdom10.eso

Retour à la liste

Numérotation des lignes : 

kdom10

  1. C KDOM10    SOURCE    CB215821  20/11/25    13:31:01     10792          
  2.       SUBROUTINE KDOM10(MTAB)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET            :  CASTEM 2000
  7. C
  8. C NOM               :  KDOM10
  9. C
  10. C DESCRIPTION       :  Subroutine called by KDOM1 in the case of EULER
  11. C                      model
  12. C                      We fill the domain table MTAB
  13. C
  14. C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  15. C
  16. C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/LTMF
  17. C
  18. C************************************************************************
  19. C
  20. C
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23. C
  24.       INTEGER MTAB, JG, IELEM, ISOUS, NBELEM, NBNN, NBREF, NBSOUS, NBS
  25.      &     ,NBE0, IGEOM, JGM, JGN, NN1, NN2, NN3, NN4, NN5, NN6, NTP
  26.      &     ,LAST, LISFAC(6), INOE, NNOEU, NFAC, NNOEUT, LISFAT(4), NFACT
  27.      &     ,LASTT,IFAC, NSOM, LASTS, NNS, LISSOM(8),LIFAC(5,6)
  28.      &     ,LIFACT(4,4), NBSFP, MCHPSU, MCHPNO, MCHPMR, MCHDIA
  29.       REAl*8 VOL, CEL(3), VOL1
  30.       LOGICAL LOGCOM
  31.       CHARACTER*8 TYPI
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC SMELEME
  36. -INC SMLENTI
  37. -INC SMCHPOI
  38. -INC SMLMOTS
  39. -INC SMCOORD
  40.       POINTEUR MELCEN.MELEME, MELMAI.MELEME, MLREST.MLENTI
  41.      &     , MLRES.MLENTI, MELTFA.MELEME, MLRESS.MLENTI
  42.      &     , MELSOM.MELEME, MELFAC.MELEME, MELFAL.MELEME, MLEFAC.MLENTI
  43.      &     , MLETOF.MLENTI, IPTT.MELEME, IPTQ.MELEME, MELFAP.MELEME
  44. C
  45. C Elements allowed are 'SEG3' 'TRI7' 'QUA9' 'TE15' 'PY19'  'PR21' 'CU27'
  46. C ITYPEL                3       7      11     35     36      34      33
  47. C
  48.       TYPI='MAILLAGE'
  49.       CALL ACMO(MTAB,'QUAF',TYPI,MELEME)
  50.       IF(IERR.NE.0)GOTO 9999
  51. C
  52. C                                                 2D             3D
  53. C**** 'MAILLAGE'       complex                1D/2D elts      2D/3D elts
  54. C     'CENTRE' 'POI1' (ITYPEL = 1)            1D/2D elts      2D/3D elts
  55. C     'SOMMET' 'POI1' (ITYPEL = 1)              2D elts         3D elts
  56. C     'FACE'   'POI1' (ITYPEL = 1)              2D elts         3D elts
  57. C     'FACEL'  'SEG3' (ITYPEL = 3)              2D elts         3D elts
  58. C     'FACEP'  'SEG3' (ITYPEL = 3) in 2D        2D elts         3D elts
  59. C                     complex  in 3D
  60. C
  61. C     'ELTFA'         complex                   2D elts         3D elts
  62. C
  63.       SEGACT MELEME
  64.       NBS=MELEME.LISOUS(/1)
  65.       IF(NBS .EQ. 0) NBS=1
  66.       JG=NBS
  67. C     MLENTI contains ITYPEL
  68. C     MLENT1 contains NBELEM
  69.       SEGINI MLENTI
  70.       SEGINI MLENT1
  71.       DO ISOUS=1,NBS,1
  72.          IF(NBS .NE. 1)THEN
  73.             IPT1=MELEME.LISOUS(ISOUS)
  74.             SEGACT IPT1
  75.          ELSE
  76.             IPT1=MELEME
  77.          ENDIF
  78. C        We have already checked the elements available in KDOM2
  79. C        We have already checked that they are referred just ONCE
  80. C        (each MELEME.LISOUS(ISOUS) has different ITYPEL)
  81. C
  82.          MLENTI.LECT(ISOUS)=IPT1.ITYPEL
  83.          MLENT1.LECT(ISOUS)=IPT1.NUM(/2)
  84.       ENDDO
  85. C
  86. C**** Compatibility check
  87. C
  88. C     We do not allow 1D/2D meshes and 2D/3D meshes
  89. C
  90.       IF(IDIM.EQ.2)THEN
  91.          IF(MLENTI.LECT(1) .EQ. 3)THEN
  92.             LOGCOM=.FALSE.
  93.             IF(NBS .NE. 1)THEN
  94.                WRITE(IOIMP,*) 'Euler model'
  95.                CALL ERREUR(21)
  96.                GOTO 9999
  97.             ENDIF
  98.          ELSE
  99.             LOGCOM=.TRUE.
  100.             DO ISOUS=2,NBS,1
  101.                IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  102.                   WRITE(IOIMP,*) 'Euler model'
  103.                   WRITE(IOIMP,*) 'No mixing between 1D and 2D'
  104.                   CALL ERREUR(21)
  105.                   GOTO 9999
  106.                ENDIF
  107.             ENDDO
  108.          ENDIF
  109.       ELSE
  110. C
  111. C****** 3D.
  112. C       No 1D possibility
  113. C
  114.          DO ISOUS=1,NBS,1
  115.             IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  116.                WRITE(IOIMP,*) 'Euler model'
  117.                WRITE(IOIMP,*) 'No 1D meshes in 3D'
  118.                CALL ERREUR(21)
  119.                GOTO 9999
  120.             ENDIF
  121.          ENDDO
  122. C
  123.          IF((MLENTI.LECT(1) .EQ. 7) .OR. (MLENTI.LECT(1) .EQ. 11))THEN
  124.             LOGCOM=.FALSE.
  125.             DO ISOUS=1,NBS,1
  126.                IF((MLENTI.LECT(ISOUS) .NE. 7) .AND.
  127.      &              (MLENTI.LECT(ISOUS) .NE. 11))THEN
  128.                   WRITE(IOIMP,*) 'Euler model'
  129.                   WRITE(IOIMP,*) 'No mixing between 2D and 3D'
  130.                   CALL ERREUR(21)
  131.                   GOTO 9999
  132.                ENDIF
  133.             ENDDO
  134.          ELSE
  135.             LOGCOM=.TRUE.
  136.             DO ISOUS=2,NBS,1
  137.                IF((MLENTI.LECT(NBS) .EQ. 7) .OR.
  138.      &              (MLENTI.LECT(NBS) .EQ. 11))THEN
  139.                   WRITE(IOIMP,*) 'Euler model'
  140.                   WRITE(IOIMP,*) 'No mixing between 2D and 3D'
  141.                   CALL ERREUR(21)
  142.                   GOTO 9999
  143.                ENDIF
  144.             ENDDO
  145.          ENDIF
  146.       ENDIF
  147. C
  148. C**** 'MAILLAGE'
  149. C     'CENTRE'
  150. C
  151. C     Initialisation
  152. C
  153.       SEGINI, MELMAI=MELEME
  154.       NBREF=0
  155.       IF(NBS .EQ. 1)THEN
  156.          ISOUS=1
  157.          IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  158. C           SEG3 -> SEG2
  159.             MELMAI.ITYPEL=2
  160.             NBNN=2
  161.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  162. C           TRI7 -> TRI3
  163.             MELMAI.ITYPEL=4
  164.             NBNN=3
  165.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  166. C           QUA9 -> QUA4
  167.             MELMAI.ITYPEL=8
  168.             NBNN=4
  169.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  170. C           TE15 -> TET4
  171.             MELMAI.ITYPEL=23
  172.             NBNN=4
  173.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  174. C           PY19 -> PYR5
  175.             MELMAI.ITYPEL=25
  176.             NBNN=5
  177.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  178. C           PR21 -> PRI6
  179.             MELMAI.ITYPEL=16
  180.             NBNN=6
  181.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  182. C           CU27 -> CUB8
  183.             MELMAI.ITYPEL=14
  184.             NBNN=8
  185.          ENDIF
  186.          NBELEM=MLENT1.LECT(ISOUS)
  187.          NBSOUS=0
  188.          SEGADJ MELMAI
  189.          NBE0=NBELEM
  190.       ELSE
  191.          NBE0=0
  192.          DO ISOUS=1,NBS,1
  193.             NBELEM=MLENT1.LECT(ISOUS)
  194.             IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  195.                WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  196.                CALL ERREUR(5)
  197.                GOTO 9999
  198.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  199. C              TRI7 -> TRI3
  200.                NBNN=3
  201.                MELMAI.ITYPEL=4
  202.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  203. C              QUA9 -> QUA4
  204.                MELMAI.ITYPEL=8
  205.                NBNN=4
  206.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  207. C              TE15 -> TET4
  208.                MELMAI.ITYPEL=23
  209.                NBNN=4
  210.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  211. C              PY19 -> PYR5
  212.                MELMAI.ITYPEL=25
  213.                NBNN=5
  214.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  215. C              PR21 -> PRI6
  216.                MELMAI.ITYPEL=16
  217.                NBNN=6
  218.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  219. C              CU27 -> CUB8
  220.                MELMAI.ITYPEL=14
  221.                NBNN=8
  222.             ENDIF
  223.             NBSOUS=0
  224.             SEGINI IPT2
  225.             MELMAI.LISOUS(ISOUS)=IPT2
  226.             IPT2.ITYPEL=MELMAI.ITYPEL
  227.             MELMAI.ITYPEL=0
  228.             NBE0=NBE0+NBELEM
  229.             IPT1=MELEME.LISOUS(ISOUS)
  230.          ENDDO
  231.       ENDIF
  232. C
  233.       NBELEM=NBE0
  234.       NBNN=1
  235.       NBSOUS=0
  236.       NBREF=0
  237.       SEGINI MELCEN
  238.       MELCEN.ITYPEL=1
  239.       NBE0=0
  240. C
  241. C**** Filling
  242. C
  243.       DO ISOUS=1,NBS,1
  244.          IF(NBS.EQ.1)THEN
  245.             IPT1=MELEME
  246.             IPT2=MELMAI
  247.          ELSE
  248.             IPT1=MELEME.LISOUS(ISOUS)
  249.             IPT2=MELMAI.LISOUS(ISOUS)
  250.          ENDIF
  251.          NBELEM=MLENT1.LECT(ISOUS)
  252.          IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  253. C           SEG
  254.             DO IELEM=1,NBELEM,1
  255.                NBE0=NBE0+1
  256.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  257.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  258.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  259.                MELCEN.NUM(1,NBE0)=IPT1.NUM(2,IELEM)
  260.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  261.             ENDDO
  262.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  263. C           TRI
  264.             DO IELEM=1,NBELEM,1
  265.                NBE0=NBE0+1
  266.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  267.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  268.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  269.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  270.                MELCEN.NUM(1,NBE0)=IPT1.NUM(7,IELEM)
  271.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  272.             ENDDO
  273.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  274. C           QUA
  275.             DO IELEM=1,NBELEM,1
  276.                NBE0=NBE0+1
  277.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  278.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  279.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  280.                IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  281.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  282.                MELCEN.NUM(1,NBE0)=IPT1.NUM(9,IELEM)
  283.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  284.             ENDDO
  285.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  286. C           TET
  287.             DO IELEM=1,NBELEM,1
  288.                NBE0=NBE0+1
  289.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  290.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  291.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  292.                IPT2.NUM(4,IELEM)=IPT1.NUM(10,IELEM)
  293.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  294.                MELCEN.NUM(1,NBE0)=IPT1.NUM(15,IELEM)
  295.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  296.             ENDDO
  297.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  298. C           PYR
  299.             DO IELEM=1,NBELEM,1
  300.                NBE0=NBE0+1
  301.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  302.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  303.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  304.                IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  305.                IPT2.NUM(5,IELEM)=IPT1.NUM(13,IELEM)
  306.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  307.                MELCEN.NUM(1,NBE0)=IPT1.NUM(19,IELEM)
  308.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  309.             ENDDO
  310.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  311. C           PRI
  312.             DO IELEM=1,NBELEM,1
  313.                NBE0=NBE0+1
  314.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  315.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  316.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  317.                IPT2.NUM(4,IELEM)=IPT1.NUM(10,IELEM)
  318.                IPT2.NUM(5,IELEM)=IPT1.NUM(12,IELEM)
  319.                IPT2.NUM(6,IELEM)=IPT1.NUM(14,IELEM)
  320.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  321.                MELCEN.NUM(1,NBE0)=IPT1.NUM(21,IELEM)
  322.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  323.             ENDDO
  324.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  325. C           CUB
  326.             DO IELEM=1,NBELEM,1
  327.                NBE0=NBE0+1
  328.                IPT2.NUM(1,IELEM)=IPT1.NUM(1,IELEM)
  329.                IPT2.NUM(2,IELEM)=IPT1.NUM(3,IELEM)
  330.                IPT2.NUM(3,IELEM)=IPT1.NUM(5,IELEM)
  331.                IPT2.NUM(4,IELEM)=IPT1.NUM(7,IELEM)
  332.                IPT2.NUM(5,IELEM)=IPT1.NUM(13,IELEM)
  333.                IPT2.NUM(6,IELEM)=IPT1.NUM(15,IELEM)
  334.                IPT2.NUM(7,IELEM)=IPT1.NUM(17,IELEM)
  335.                IPT2.NUM(8,IELEM)=IPT1.NUM(19,IELEM)
  336.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  337.                MELCEN.NUM(1,NBE0)=IPT1.NUM(27,IELEM)
  338.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  339.             ENDDO
  340.          ELSE
  341.             WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  342.             CALL ERREUR(5)
  343.          ENDIF
  344.       ENDDO
  345.       CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI)
  346.       CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN)
  347.       SEGDES MELCEN
  348.       SEGDES MELMAI
  349. C
  350. C**** Volume
  351. C
  352.       TYPI='CENTRE  '
  353.       JGN=4
  354.       JGM=1
  355.       SEGINI MLMOTS
  356.       MLMOTS.MOTS(1)='SCAL'
  357.       CALL KRCHP1(TYPI,MELCEN,MCHPOI,MLMOTS)
  358.       CALL LICHT(MCHPOI,MPOVAL,TYPI,IGEOM)
  359. C     SEGACT MPOVAL
  360. C
  361.       SEGSUP MLMOTS
  362.       NBE0=0
  363.       DO ISOUS=1,NBS,1
  364.          IF(NBS.EQ.1) THEN
  365.             IPT1=MELEME
  366.          ELSE
  367.             IPT1=MELEME.LISOUS(ISOUS)
  368.          ENDIF
  369. C
  370.          NBELEM=MLENT1.LECT(ISOUS)
  371.          IF(MLENTI.LECT(ISOUS) .EQ. 3)THEN
  372. C           SEG3
  373.             DO IELEM=1,NBELEM,1
  374.                NBE0=NBE0+1
  375.                NN1=IPT1.NUM(1,IELEM)
  376.                NN2=IPT1.NUM(2,IELEM)
  377.                NN3=IPT1.NUM(3,IELEM)
  378.                CALL KDOM5(NN1,NN2,NN3,VOL)
  379.                MPOVAL.VPOCHA(NBE0,1)=VOL
  380.             ENDDO
  381.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  382. C           TRI
  383.             DO IELEM=1,NBELEM,1
  384.                NBE0=NBE0+1
  385.                NN1=IPT1.NUM(1,IELEM)
  386.                NN2=IPT1.NUM(3,IELEM)
  387.                NN3=IPT1.NUM(5,IELEM)
  388.                NN4=IPT1.NUM(7,IELEM)
  389. C              Vol TRI7 as a vol of a degenerate QUA9
  390.                CALL KDOM6(NN1,NN2,NN3,NN3,NN4,VOL)
  391.                MPOVAL.VPOCHA(NBE0,1)=VOL
  392.             ENDDO
  393.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  394. C           QUA
  395.             DO IELEM=1,NBELEM,1
  396.                NBE0=NBE0+1
  397.                NN1=IPT1.NUM(1,IELEM)
  398.                NN2=IPT1.NUM(3,IELEM)
  399.                NN3=IPT1.NUM(5,IELEM)
  400.                NN4=IPT1.NUM(7,IELEM)
  401.                NN5=IPT1.NUM(9,IELEM)
  402.                CALL KDOM6(NN1,NN2,NN3,NN4,NN5,VOL)
  403.                MPOVAL.VPOCHA(NBE0,1)=VOL
  404.             ENDDO
  405.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  406. C           TET
  407.             DO IELEM=1,NBELEM,1
  408.                NBE0=NBE0+1
  409.                NN1=IPT1.NUM(1,IELEM)
  410.                NN2=IPT1.NUM(3,IELEM)
  411.                NN3=IPT1.NUM(5,IELEM)
  412.                NN4=IPT1.NUM(10,IELEM)
  413.                CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL)
  414.                MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  415.             ENDDO
  416.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  417. C           PYR
  418.             DO IELEM=1,NBELEM,1
  419.                NBE0=NBE0+1
  420.                NN1=IPT1.NUM(1,IELEM)
  421.                NN2=IPT1.NUM(3,IELEM)
  422.                NN3=IPT1.NUM(5,IELEM)
  423.                NN4=IPT1.NUM(7,IELEM)
  424.                NN5=IPT1.NUM(14,IELEM)
  425.                NN6=IPT1.NUM(13,IELEM)
  426.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL)
  427.                MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  428.             ENDDO
  429.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  430. C           PRI
  431. C           To compute the volume, we divide it into 2
  432. C           TET et 3 PYR
  433. C
  434.             DO IELEM=1,NBELEM,1
  435.                VOL=0.0D0
  436.                NBE0=NBE0+1
  437.                NN1=IPT1.NUM(1,IELEM)
  438.                NN2=IPT1.NUM(3,IELEM)
  439.                NN3=IPT1.NUM(5,IELEM)
  440.                NN4=IPT1.NUM(21,IELEM)
  441.                CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  442.                VOL=VOL+VOL1
  443.                NN1=IPT1.NUM(14,IELEM)
  444.                NN2=IPT1.NUM(12,IELEM)
  445.                NN3=IPT1.NUM(10,IELEM)
  446.                NN4=IPT1.NUM(21,IELEM)
  447.                CALL KDOM4(NN1,NN2,NN3,NN4,CEL,VOL1)
  448.                VOL=VOL+VOL1
  449.                NN1=IPT1.NUM(1,IELEM)
  450.                NN2=IPT1.NUM(10,IELEM)
  451.                NN3=IPT1.NUM(12,IELEM)
  452.                NN4=IPT1.NUM(3,IELEM)
  453.                NN5=IPT1.NUM(16,IELEM)
  454.                NN6=IPT1.NUM(21,IELEM)
  455.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  456.                VOL=VOL+VOL1
  457.                NN1=IPT1.NUM(3,IELEM)
  458.                NN2=IPT1.NUM(12,IELEM)
  459.                NN3=IPT1.NUM(14,IELEM)
  460.                NN4=IPT1.NUM(5,IELEM)
  461.                NN5=IPT1.NUM(17,IELEM)
  462.                NN6=IPT1.NUM(21,IELEM)
  463.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  464.                VOL=VOL+VOL1
  465.                NN1=IPT1.NUM(10,IELEM)
  466.                NN2=IPT1.NUM(1,IELEM)
  467.                NN3=IPT1.NUM(5,IELEM)
  468.                NN4=IPT1.NUM(14,IELEM)
  469.                NN5=IPT1.NUM(18,IELEM)
  470.                NN6=IPT1.NUM(21,IELEM)
  471.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  472.                VOL=VOL+VOL1
  473.                MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  474.             ENDDO
  475. C
  476.          ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  477. C           CUB
  478. C           To compute the volume, we divide it into 6 PYR
  479. C
  480.             DO IELEM=1,NBELEM,1
  481.                VOL=0.0D0
  482.                NBE0=NBE0+1
  483.                NN1=IPT1.NUM(1,IELEM)
  484.                NN2=IPT1.NUM(3,IELEM)
  485.                NN3=IPT1.NUM(5,IELEM)
  486.                NN4=IPT1.NUM(7,IELEM)
  487.                NN5=IPT1.NUM(25,IELEM)
  488.                NN6=IPT1.NUM(27,IELEM)
  489.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  490.                VOL=VOL+VOL1
  491.                NN1=IPT1.NUM(19,IELEM)
  492.                NN2=IPT1.NUM(17,IELEM)
  493.                NN3=IPT1.NUM(15,IELEM)
  494.                NN4=IPT1.NUM(13,IELEM)
  495.                NN5=IPT1.NUM(26,IELEM)
  496.                NN6=IPT1.NUM(27,IELEM)
  497.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  498.                VOL=VOL+VOL1
  499.                NN1=IPT1.NUM(1,IELEM)
  500.                NN2=IPT1.NUM(13,IELEM)
  501.                NN3=IPT1.NUM(15,IELEM)
  502.                NN4=IPT1.NUM(3,IELEM)
  503.                NN5=IPT1.NUM(21,IELEM)
  504.                NN6=IPT1.NUM(27,IELEM)
  505.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  506.                VOL=VOL+VOL1
  507.                NN1=IPT1.NUM(3,IELEM)
  508.                NN2=IPT1.NUM(15,IELEM)
  509.                NN3=IPT1.NUM(17,IELEM)
  510.                NN4=IPT1.NUM(5,IELEM)
  511.                NN5=IPT1.NUM(22,IELEM)
  512.                NN6=IPT1.NUM(27,IELEM)
  513.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  514.                VOL=VOL+VOL1
  515.                NN1=IPT1.NUM(7,IELEM)
  516.                NN2=IPT1.NUM(5,IELEM)
  517.                NN3=IPT1.NUM(17,IELEM)
  518.                NN4=IPT1.NUM(19,IELEM)
  519.                NN5=IPT1.NUM(23,IELEM)
  520.                NN6=IPT1.NUM(27,IELEM)
  521.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  522.                VOL=VOL+VOL1
  523.                NN1=IPT1.NUM(19,IELEM)
  524.                NN2=IPT1.NUM(13,IELEM)
  525.                NN3=IPT1.NUM(1,IELEM)
  526.                NN4=IPT1.NUM(7,IELEM)
  527.                NN5=IPT1.NUM(24,IELEM)
  528.                NN6=IPT1.NUM(27,IELEM)
  529.                CALL KDOM3(NN1,NN2,NN3,NN4,NN5,NN6,CEL,VOL1)
  530.                VOL=VOL+VOL1
  531.                MPOVAL.VPOCHA(NBE0,1)=ABS(VOL)
  532.             ENDDO
  533.          ELSE
  534.             WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  535.             CALL ERREUR(5)
  536.          ENDIF
  537.       ENDDO
  538. C
  539.       CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHPOI)
  540. C
  541. C
  542. C**** For the moment we have:
  543. C     'QUAF'
  544. C     'MAILLAGE'
  545. C     'CENTRE'
  546. C     'XXVOLUM'
  547. C
  548. C     In the complete case (2D mesh in 2D and 3D mesh in 3D):
  549. C
  550.       IF(LOGCOM)THEN
  551. C
  552. C******* We create ELTFA
  553. C
  554.          SEGINI, MELTFA=MELEME
  555.          NBREF=0
  556.          IF(NBS .EQ. 1)THEN
  557.             ISOUS=1
  558.             IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  559. C              TRI3
  560.                NBNN=3
  561.                MELTFA.ITYPEL=4
  562. C              ELTFA TRI3
  563.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  564. C              QUA4
  565.                NBNN=4
  566.                MELTFA.ITYPEL=8
  567. C              ELTFA QUA4
  568.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  569. C              TET4
  570.                NBNN=4
  571.                MELTFA.ITYPEL=23
  572. C              ELTFA TET4
  573.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  574. C              PYR5
  575.                NBNN=5
  576.                MELTFA.ITYPEL=9
  577. C              ELTFA QUA5
  578.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  579. C              PRI6
  580.                NBNN=5
  581.                MELTFA.ITYPEL=25
  582. C              ELTFA PYR5
  583.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  584. C              CUB8
  585.                NBNN=6
  586.                MELTFA.ITYPEL=16
  587. C              ELTFA PRI6
  588.             ELSE
  589.                WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  590.                CALL ERREUR(5)
  591.                GOTO 9999
  592.             ENDIF
  593.             NBELEM=MLENT1.LECT(ISOUS)
  594.             NBSOUS=0
  595.             SEGADJ MELTFA
  596.          ELSE
  597.             DO ISOUS=1,NBS,1
  598.                NBELEM=MLENT1.LECT(ISOUS)
  599.                IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  600. C              TRI3
  601.                   NBNN=3
  602.                   MELTFA.ITYPEL=4
  603. C              ELTFA TRI3
  604.                ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  605. C              QUA4
  606.                   NBNN=4
  607.                   MELTFA.ITYPEL=8
  608. C              ELTFA QUA4
  609.                ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  610. C              TET4
  611.                   NBNN=4
  612.                   MELTFA.ITYPEL=23
  613. C              ELTFA TET4
  614.                ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  615. C              PYR5
  616.                   NBNN=5
  617.                   MELTFA.ITYPEL=9
  618. C              ELTFA QUA5
  619.                ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  620. C              PRI6
  621.                   NBNN=5
  622.                   MELTFA.ITYPEL=25
  623. C              ELTFA PYR5
  624.                ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  625. C              CUB8
  626.                   NBNN=6
  627.                   MELTFA.ITYPEL=16
  628. C              ELTFA PRI6
  629.                ELSE
  630.                   WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  631.                   CALL ERREUR(5)
  632.                   GOTO 9999
  633.                ENDIF
  634.                NBSOUS=0
  635.                SEGINI IPT2
  636.                MELTFA.LISOUS(ISOUS)=IPT2
  637. C
  638.                IPT2.ITYPEL=MELTFA.ITYPEL
  639.                MELTFA.ITYPEL=0
  640.             ENDDO
  641.          ENDIF
  642. C
  643. C******* We fill ELTFA
  644. C        We also count:
  645. C        NFACT = number of triangular faces
  646. C        NFAC  = number of non-triangular faces
  647. C        NSOM  = number of SOMMET
  648. C
  649.          NTP=nbpts
  650.          JG=NTP
  651.          NFAC=0
  652.          NFACT=0
  653.          NSOM=0
  654.  
  655.          LAST=-1
  656.          SEGINI MLRES
  657.          LASTT=-1
  658.          SEGINI MLREST
  659.          LASTS=-1
  660.          SEGINI MLRESS
  661. C        LAST+MLRES = chaining list to find the (non-triangular faces)
  662.          DO ISOUS=1,NBS,1
  663.             IF(NBS.EQ.1) THEN
  664.                IPT1=MELEME
  665.                IPT2=MELTFA
  666.             ELSE
  667.                IPT1=MELEME.LISOUS(ISOUS)
  668.                IPT2=MELTFA.LISOUS(ISOUS)
  669.             ENDIF
  670. C
  671.             NBELEM=MLENT1.LECT(ISOUS)
  672.             IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  673. C              TRI (2D)
  674.                LISFAC(1)=2
  675.                LISFAC(2)=4
  676.                LISFAC(3)=6
  677.                LISSOM(1)=1
  678.                LISSOM(2)=3
  679.                LISSOM(3)=5
  680.                NNS=3
  681.                NNOEU=3
  682.                NNOEUT=0
  683.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  684. C             QUA (2D)
  685.                LISFAC(1)=2
  686.                LISFAC(2)=4
  687.                LISFAC(3)=6
  688.                LISFAC(4)=8
  689.                LISSOM(1)=1
  690.                LISSOM(2)=3
  691.                LISSOM(3)=5
  692.                LISSOM(4)=7
  693.                NNS=4
  694.                NNOEU=4
  695.                NNOEUT=0
  696.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  697. C              TET
  698.                LISFAT(1)=11
  699.                LISFAT(2)=12
  700.                LISFAT(3)=13
  701.                LISFAT(4)=14
  702.                LISSOM(1)=1
  703.                LISSOM(2)=3
  704.                LISSOM(3)=5
  705.                LISSOM(4)=10
  706.                NNS=4
  707.                NNOEU=0
  708.                NNOEUT=4
  709.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  710. C              PYR
  711.                LISFAC(1)=14
  712.                LISFAT(1)=15
  713.                LISFAT(2)=16
  714.                LISFAT(3)=17
  715.                LISFAT(4)=18
  716.                LISSOM(1)=1
  717.                LISSOM(2)=3
  718.                LISSOM(3)=5
  719.                LISSOM(4)=7
  720.                LISSOM(5)=13
  721.                NNS=5
  722.                NNOEU=1
  723.                NNOEUT=4
  724.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  725. C              PRI
  726.                LISFAC(1)=16
  727.                LISFAC(2)=17
  728.                LISFAC(3)=18
  729.                LISFAT(1)=19
  730.                LISFAT(2)=20
  731.                LISSOM(1)=1
  732.                LISSOM(2)=3
  733.                LISSOM(3)=5
  734.                LISSOM(4)=10
  735.                LISSOM(5)=12
  736.                LISSOM(6)=14
  737.                NNS=6
  738.                NNOEU=3
  739.                NNOEUT=2
  740.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  741. C              CUB
  742.                LISFAC(1)=25
  743.                LISFAC(2)=26
  744.                LISFAC(3)=21
  745.                LISFAC(4)=22
  746.                LISFAC(5)=23
  747.                LISFAC(6)=24
  748.                LISSOM(1)=1
  749.                LISSOM(2)=3
  750.                LISSOM(3)=5
  751.                LISSOM(4)=7
  752.                LISSOM(5)=13
  753.                LISSOM(6)=15
  754.                LISSOM(7)=17
  755.                LISSOM(8)=19
  756.                NNS=8
  757.                NNOEU=6
  758.                NNOEUT=0
  759.             ELSE
  760.                WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  761.                CALL ERREUR(5)
  762.             ENDIF
  763. C
  764.             DO IELEM=1,NBELEM,1
  765.                IFAC=0
  766.                DO INOE=1,NNOEU,1
  767.                   NN1=IPT1.NUM(LISFAC(INOE),IELEM)
  768.                   IFAC=IFAC+1
  769.                   IPT2.NUM(IFAC,IELEM)=NN1
  770.                   IF(MLRES.LECT(NN1) .EQ. 0)THEN
  771.                      NFAC=NFAC+1
  772.                      MLRES.LECT(NN1)=LAST
  773.                      LAST=NN1
  774.                   ENDIF
  775.                ENDDO
  776.                DO INOE=1,NNOEUT,1
  777.                   NN1=IPT1.NUM(LISFAT(INOE),IELEM)
  778.                   IFAC=IFAC+1
  779.                   IPT2.NUM(IFAC,IELEM)=NN1
  780.                   IF(MLREST.LECT(NN1) .EQ. 0)THEN
  781.                      NFACT=NFACT+1
  782.                      MLREST.LECT(NN1)=LASTT
  783.                      LASTT=NN1
  784.                   ENDIF
  785.                ENDDO
  786.                DO INOE=1,NNS,1
  787.                   NN1=IPT1.NUM(LISSOM(INOE),IELEM)
  788.                   IF(MLRESS.LECT(NN1) .EQ. 0)THEN
  789.                      NSOM=NSOM+1
  790.                      MLRESS.LECT(NN1)=LASTS
  791.                      LASTS=NN1
  792.                   ENDIF
  793.                ENDDO
  794. C
  795. C************* Cas particulier: PRISME
  796. C
  797.                IF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  798.                   NN1=IPT2.NUM(1,IELEM)
  799.                   NN2=IPT2.NUM(2,IELEM)
  800.                   NN3=IPT2.NUM(3,IELEM)
  801.                   DO INOE=1,2
  802.                      IPT2.NUM(INOE,IELEM)=IPT2.NUM(INOE+3,IELEM)
  803.                   ENDDO
  804.                   IPT2.NUM(3,IELEM)=NN1
  805.                   IPT2.NUM(4,IELEM)=NN2
  806.                   IPT2.NUM(5,IELEM)=NN3
  807.                ENDIF
  808.             ENDDO
  809. C
  810. C
  811.          ENDDO
  812.          SEGDES MELTFA
  813.          CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA)
  814.  
  815. CC
  816. CC******* Test
  817. CC
  818. C         write(*,*) 'Triangular faces ', nfact
  819. C 10      if(lastt .ne. -1)then
  820. C            write(*,*) lastt
  821. C            lastt=mlrest.lect(lastt)
  822. C         endif
  823. C         if(lastt .ne. -1) goto 10
  824. C         write(*,*) 'Non triangular faces ', nfac
  825. C 20      if(last  .ne. -1)then
  826. C            write(*,*) last
  827. C            last=mlres.lect(last)
  828. C         endif
  829. C         if(last .ne. -1) goto 20
  830. C         write(*,*) 'Sommets ', nsom
  831. C 30      if(lasts  .ne. -1)then
  832. C            write(*,*) lasts
  833. C            lasts=mlress.lect(lasts)
  834. C         endif
  835. C         if(lasts .ne. -1) goto 30
  836. C
  837. CC
  838. CC******* Fin test
  839. CC
  840. C
  841. C******** Creation of SOMMET
  842. C
  843.          NBELEM=NSOM
  844.          NBNN=1
  845.          NBSOUS=0
  846.          NBREF=0
  847.          SEGINI MELSOM
  848.          MELSOM.ITYPEL=1
  849.          DO IELEM=1,NSOM,1
  850.             MELSOM.NUM(1,IELEM)=LASTS
  851.             LASTS=MLRESS.LECT(LASTS)
  852.          ENDDO
  853.          IF(LASTS .NE. -1)THEN
  854.             WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  855.             CALL ERREUR(5)
  856.          ENDIF
  857.          SEGDES MELSOM
  858.          CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM)
  859.          SEGSUP MLRESS
  860. C
  861. C******** Creation of FACE (in 3D, triangle first)
  862. C
  863.          NBELEM=NFAC+NFACT
  864.          NBNN=1
  865.          NBSOUS=0
  866.          NBREF=0
  867.          SEGINI MELFAC
  868.          MELFAC.ITYPEL=1
  869.          DO IELEM=1,NFACT,1
  870.             MELFAC.NUM(1,IELEM)=LASTT
  871.             LASTT=MLREST.LECT(LASTT)
  872.          ENDDO
  873.          IF(LASTT .NE. -1)THEN
  874.             WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  875.             CALL ERREUR(5)
  876.          ENDIF
  877.          DO IELEM=1,NFAC,1
  878.             MELFAC.NUM(1,NFACT+IELEM)=LAST
  879.             LAST=MLRES.LECT(LAST)
  880.          ENDDO
  881.          IF(LAST .NE. -1)THEN
  882.             WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  883.             CALL ERREUR(5)
  884.          ENDIF
  885.          SEGDES MELFAC
  886.          SEGSUP MLRES
  887.          SEGSUP MLREST
  888.          CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC)
  889. C
  890. C******* Creation of FACEL and FACEP
  891. C
  892.          CALL KRIPAD(MELFAC,MLEFAC)
  893. C        SEGINI MLEFAC
  894.          JG=NFAC+NFACT
  895.          SEGINI MLETOF
  896. C
  897. C        MLETOF.LECT(I1) = how many times has the i-th face of MELFAP
  898. C                          already been touched?
  899. C
  900.          NBELEM=NFAC+NFACT
  901.          NBNN=3
  902.          NBSOUS=0
  903.          NBREF=0
  904.          SEGINI MELFAL
  905.          MELFAL.ITYPEL=3
  906. C
  907.          IF(IDIM.EQ.2)THEN
  908. C           FACEP is a SEG3
  909.             NBELEM=NFAC
  910.             NBNN=3
  911.             NBSOUS=0
  912.             NBREF=0
  913.             SEGINI MELFAP
  914.             MELFAP.ITYPEL=3
  915.             IPTQ=MELFAP
  916.          ELSEIF(NFAC.EQ.0)THEN
  917. C           In 3D we have triangles only
  918. C           TRI4
  919.             NBELEM=NFACT
  920.             NBSOUS=0
  921.             NBREF=0
  922.             NBNN=4
  923.             SEGINI MELFAP
  924.             IPTT=MELFAP
  925.             MELFAP.ITYPEL=5
  926.          ELSEIF(NFACT.EQ.0)THEN
  927. C           In 3D we have quadrangles only
  928. C           QUA5
  929.             NBELEM=NFAC
  930.             NBSOUS=0
  931.             NBREF=0
  932.             NBNN=5
  933.             SEGINI MELFAP
  934.             IPTQ=MELFAP
  935.             MELFAP.ITYPEL=9
  936.          ELSE
  937. C           TRI4 5
  938. C           QUA5 9
  939.             NBELEM=0
  940.             NBNN=0
  941.             NBSOUS=2
  942.             NBREF=0
  943.             SEGINI MELFAP
  944.             MELFAP.ITYPEL=0
  945. C
  946.             NBELEM=NFACT
  947.             NBSOUS=0
  948.             NBREF=0
  949.             NBNN=4
  950.             SEGINI IPTT
  951.             MELFAP.LISOUS(1)=IPTT
  952.             IPTT.ITYPEL=5
  953. C
  954.             NBELEM=NFAC
  955.             NBSOUS=0
  956.             NBREF=0
  957.             NBNN=5
  958.             SEGINI IPTQ
  959.             MELFAP.LISOUS(2)=IPTQ
  960.             IPTQ.ITYPEL=9
  961.          ENDIF
  962. C        NBSFP = NBSOUS for FACEP
  963. C
  964.          NBSFP=NBSOUS
  965. C
  966.          DO ISOUS=1,NBS,1
  967. C
  968. C********** Loop on the elementary mesh of the QUAF
  969. C
  970. C           We recall that
  971. C           MLENTI.LECT(ISOUS) contains the type of support of
  972. C                              MELEME.LISOUS
  973. C           MLENT1.LECT(ISOUS) contains the number of elements of
  974. C                              MELEME.LISOUS
  975. C
  976.             IF(NBS.EQ.1) THEN
  977.                IPT1=MELEME
  978.             ELSE
  979.                IPT1=MELEME.LISOUS(ISOUS)
  980.             ENDIF
  981. C
  982.             IF(MLENTI.LECT(ISOUS) .EQ. 7)THEN
  983. C              TRI (2D)
  984.                LIFAC(1,1)=2
  985.                LIFAC(2,1)=1
  986.                LIFAC(3,1)=3
  987.                LIFAC(1,2)=4
  988.                LIFAC(2,2)=3
  989.                LIFAC(3,2)=5
  990.                LIFAC(1,3)=6
  991.                LIFAC(2,3)=5
  992.                LIFAC(3,3)=1
  993. C              Here we put the center point in LISSOM
  994.                LISSOM(1)=7
  995. C              Number of non-triangular and triangular faces
  996.                NNOEU=3
  997.                NNOEUT=0
  998. C
  999.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 11)THEN
  1000. C             QUA (2D)
  1001.                LIFAC(1,1)=2
  1002.                LIFAC(2,1)=1
  1003.                LIFAC(3,1)=3
  1004.                LIFAC(1,2)=4
  1005.                LIFAC(2,2)=3
  1006.                LIFAC(3,2)=5
  1007.                LIFAC(1,3)=6
  1008.                LIFAC(2,3)=5
  1009.                LIFAC(3,3)=7
  1010.                LIFAC(1,4)=8
  1011.                LIFAC(2,4)=7
  1012.                LIFAC(3,4)=1
  1013.                LISSOM(1)=9
  1014.                NNOEU=4
  1015.                NNOEUT=0
  1016.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 35)THEN
  1017. C              TET
  1018.                LIFACT(1,1)=11
  1019.                LIFACT(2,1)=1
  1020.                LIFACT(3,1)=3
  1021.                LIFACT(4,1)=5
  1022.                LIFACT(1,2)=12
  1023.                LIFACT(2,2)=1
  1024.                LIFACT(3,2)=10
  1025.                LIFACT(4,2)=3
  1026.                LIFACT(1,3)=13
  1027.                LIFACT(2,3)=3
  1028.                LIFACT(3,3)=10
  1029.                LIFACT(4,3)=5
  1030.                LIFACT(1,4)=14
  1031.                LIFACT(2,4)=10
  1032.                LIFACT(3,4)=1
  1033.                LIFACT(4,4)=5
  1034.                LISSOM(1)=15
  1035.                NNOEU=0
  1036.                NNOEUT=4
  1037.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 36)THEN
  1038. C              PYR
  1039.                LIFAC(1,1)=14
  1040.                LIFAC(2,1)=1
  1041.                LIFAC(3,1)=3
  1042.                LIFAC(4,1)=5
  1043.                LIFAC(5,1)=7
  1044.                LIFACT(1,1)=15
  1045.                LIFACT(2,1)=1
  1046.                LIFACT(3,1)=13
  1047.                LIFACT(4,1)=3
  1048.                LIFACT(1,2)=16
  1049.                LIFACT(2,2)=3
  1050.                LIFACT(3,2)=13
  1051.                LIFACT(4,2)=5
  1052.                LIFACT(1,3)=17
  1053.                LIFACT(2,3)=5
  1054.                LIFACT(3,3)=13
  1055.                LIFACT(4,3)=7
  1056.                LIFACT(1,4)=18
  1057.                LIFACT(2,4)=13
  1058.                LIFACT(3,4)=1
  1059.                LIFACT(4,4)=7
  1060.                LISSOM(1)=19
  1061.                NNOEU=1
  1062.                NNOEUT=4
  1063.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 34)THEN
  1064. C              PRI
  1065.                LIFAC(1,1)=16
  1066.                LIFAC(2,1)=1
  1067.                LIFAC(3,1)=10
  1068.                LIFAC(4,1)=12
  1069.                LIFAC(5,1)=3
  1070.                LIFAC(1,2)=17
  1071.                LIFAC(2,2)=3
  1072.                LIFAC(3,2)=12
  1073.                LIFAC(4,2)=14
  1074.                LIFAC(5,2)=5
  1075.                LIFAC(1,3)=18
  1076.                LIFAC(2,3)=1
  1077.                LIFAC(3,3)=5
  1078.                LIFAC(4,3)=14
  1079.                LIFAC(5,3)=10
  1080.                LIFACT(1,1)=19
  1081.                LIFACT(2,1)=1
  1082.                LIFACT(3,1)=3
  1083.                LIFACT(4,1)=5
  1084.                LIFACT(1,2)=20
  1085.                LIFACT(2,2)=10
  1086.                LIFACT(3,2)=14
  1087.                LIFACT(4,2)=12
  1088.                LISSOM(1)=21
  1089.                NNOEU=3
  1090.                NNOEUT=2
  1091.             ELSEIF(MLENTI.LECT(ISOUS) .EQ. 33)THEN
  1092. C              CUB
  1093.                LIFAC(1,1)=21
  1094.                LIFAC(2,1)=1
  1095.                LIFAC(3,1)=13
  1096.                LIFAC(4,1)=15
  1097.                LIFAC(5,1)=3
  1098.                LIFAC(1,2)=22
  1099.                LIFAC(2,2)=3
  1100.                LIFAC(3,2)=15
  1101.                LIFAC(4,2)=17
  1102.                LIFAC(5,2)=5
  1103.                LIFAC(1,3)=23
  1104.                LIFAC(2,3)=5
  1105.                LIFAC(3,3)=17
  1106.                LIFAC(4,3)=19
  1107.                LIFAC(5,3)=7
  1108.                LIFAC(1,4)=24
  1109.                LIFAC(2,4)=1
  1110.                LIFAC(3,4)=7
  1111.                LIFAC(4,4)=19
  1112.                LIFAC(5,4)=13
  1113.                LIFAC(1,5)=25
  1114.                LIFAC(2,5)=1
  1115.                LIFAC(3,5)=3
  1116.                LIFAC(4,5)=5
  1117.                LIFAC(5,5)=7
  1118.                LIFAC(1,6)=26
  1119.                LIFAC(2,6)=13
  1120.                LIFAC(3,6)=19
  1121.                LIFAC(4,6)=17
  1122.                LIFAC(5,6)=15
  1123.                LISSOM(1)=27
  1124.                NNOEU=6
  1125.                NNOEUT=0
  1126.             ELSE
  1127.                WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1128.                CALL ERREUR(5)
  1129.             ENDIF
  1130. C
  1131.             NBELEM=MLENT1.LECT(ISOUS)
  1132.             DO IELEM=1,NBELEM,1
  1133. C              NNOEU = number of quagrangular elements
  1134.                DO INOE=1,NNOEU,1
  1135. C                 NN1 is the global number of the face
  1136. C                 NN2 is the local number of the face in the MELEME
  1137. C                 'FACE'
  1138. C                 The MELEME 'FACE' contains : -triangular faces
  1139. C                                               (MELEME IPTT)
  1140. C                                              -non-triangular faces
  1141. C                                               (MELEME IPTQ)
  1142. C                 Then NN3 = position of NN1 in IPTQ = NN2 - NFACT
  1143. C                 where NFACT is the total number of triangular faces
  1144. C
  1145.                   NN1=IPT1.NUM(LIFAC(1,INOE),IELEM)
  1146.                   NN2=MLEFAC.LECT(NN1)
  1147.                   NN3=NN2-NFACT
  1148.                   IF(MLETOF.LECT(NN2).EQ.0)THEN
  1149. C
  1150. C                    MLETOF.LECT(NN2) = how many times the face NN2 has
  1151. C                    been touched?
  1152. C
  1153.                      MLETOF.LECT(NN2)=1
  1154.                      MELFAL.NUM(2,NN2)=NN1
  1155.                      MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1156.                      MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1157.                      IF(IDIM .EQ.2)THEN
  1158.                         IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1159.                         IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1160.                         IPTQ.NUM(3,NN3)=NN1
  1161.                      ELSE
  1162.                         IPTQ.NUM(1,NN3)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  1163.                         IPTQ.NUM(2,NN3)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  1164.                         IPTQ.NUM(3,NN3)=IPT1.NUM(LIFAC(4,INOE),IELEM)
  1165.                         IPTQ.NUM(4,NN3)=IPT1.NUM(LIFAC(5,INOE),IELEM)
  1166.                         IPTQ.NUM(5,NN3)=NN1
  1167.                      ENDIF
  1168.                   ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1169.                      MLETOF.LECT(NN2)=2
  1170.                      MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1171.                   ELSE
  1172.                      WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1173.                      CALL ERREUR(5)
  1174.                   ENDIF
  1175.                ENDDO
  1176.                DO INOE=1,NNOEUT,1
  1177. C                 NN1 is the global number of the face
  1178. C                 NN2 is the local number of the face in the MELEME
  1179. C                 'FACE' and is also the position of NN1 in IPTT
  1180. C
  1181.                   NN1=IPT1.NUM(LIFACT(1,INOE),IELEM)
  1182.                   NN2=MLEFAC.LECT(NN1)
  1183.                   IF(MLETOF.LECT(NN2).EQ.0)THEN
  1184.                      MLETOF.LECT(NN2)=1
  1185.                      MELFAL.NUM(2,NN2)=NN1
  1186.                      MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1187.                      MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1188.                      IPTT.NUM(1,NN2)=IPT1.NUM(LIFACT(2,INOE),IELEM)
  1189.                      IPTT.NUM(2,NN2)=IPT1.NUM(LIFACT(3,INOE),IELEM)
  1190.                      IPTT.NUM(3,NN2)=IPT1.NUM(LIFACT(4,INOE),IELEM)
  1191.                      IPTT.NUM(4,NN2)=NN1
  1192.                   ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  1193.                      MLETOF.LECT(NN2)=2
  1194.                      MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  1195.                   ELSE
  1196.                      WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  1197.                      CALL ERREUR(5)
  1198.                   ENDIF
  1199.                ENDDO
  1200.             ENDDO
  1201.          ENDDO
  1202.          IF(NBSFP .NE. 0)THEN
  1203.             SEGDES IPTQ
  1204.             SEGDES IPTT
  1205.          ENDIF
  1206.          SEGDES MELFAL
  1207.          SEGDES MELFAP
  1208. C         SEGDES MELFAP
  1209. C         SEGDES MELFAP
  1210. C         SEGDES MELFAP
  1211.          SEGSUP MLETOF
  1212.          SEGSUP MLEFAC
  1213.          CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL)
  1214.          CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP)
  1215. C
  1216. C******** Creation of 'XXSURFAC', 'XXNORMAF', 'MATROT'
  1217. C
  1218.          CALL KDOM11(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR)
  1219.          IF(IERR.NE.0)GOTO 9999
  1220.          CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU)
  1221.          CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO)
  1222.          CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR)
  1223. C
  1224. C******** Creation of 'XXDIEMIN'
  1225. C
  1226.          CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  1227.          IF(IERR.NE.0)GOTO 9999
  1228.          CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA)
  1229. C
  1230.       ENDIF
  1231. C
  1232. C
  1233. C***** Fin qui
  1234. C
  1235. C
  1236.       SEGSUP MLENTI
  1237.       SEGSUP MLENT1
  1238. C
  1239.  9999 RETURN
  1240. C
  1241.       END
  1242.  
  1243.  
  1244.  
  1245.  
  1246.  

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