Télécharger la plaquette Cast3M


fr en

Télécharger kdom4a.eso

Retour à la liste

Numérotation des lignes : 

kdom4a

  1. C KDOM4A    SOURCE    CB215821  20/11/25    13:31:06     10792          
  2.       SUBROUTINE KDOM4A(MTAB,MELEMQ)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET            :  CASTEM 2000
  7. C
  8. C NOM               :  KDOM4A
  9. C
  10. C DESCRIPTION       :  Subroutine called by KDOM2A
  11. C                      Axial-symmetric case, TRI7 and QUA8
  12. C                      We compute
  13. C                      MTAB . 'MAILLAGE'
  14. C                      MTAB . 'CENTRE'
  15. C                      MTAB . 'XCEN2D'
  16. C                      MTAB . 'YCEN2D'
  17. C                      MTAB . 'XXVOLUM'
  18. C                      MTAB . 'XXSURF2D'
  19. C                      and we change the position for the central points
  20. C                      of MELEMQ
  21. C
  22. C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  23. C
  24. C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/LTMF
  25. C
  26. C************************************************************************
  27. C
  28. C INPUT/OUTPUT      : MTAB   : domaine table
  29. C                     MELEMQ : QUAF mesh
  30. C************************************************************************
  31. C
  32. C Created the 24/02/04
  33. C
  34. C
  35. C**** Variables de COOPTIO
  36. C
  37. C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  38. C     &     ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
  39. C     &     ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
  40. C     &     ,IECHO,   IIMPI,  IOSPI
  41. C     &     ,IDIM,    IFICLE, IPREFI
  42. CC     &     ,MCOORD
  43. C     &     ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  44. C     &     ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  45. C     &     ,NORINC,NORVAL,NORIND,NORVAD
  46. C     &     ,NUCROU, IPSAUV, IREFOR, ISAFOR
  47. CC
  48. C
  49.       IMPLICIT INTEGER(I-N)
  50.  
  51. -INC PPARAM
  52. -INC CCOPTIO
  53. -INC SMCOORD
  54. -INC SMELEME
  55. -INC SMLMOTS
  56. -INC SMCHPOI
  57. -INC SMLENTI
  58.       INTEGER MTAB, MELEMQ
  59.      &     ,MCHPSU,MCHPNO,MCHPMR,MCHX2D,MCHY2D
  60.      &     , NBS, NBREF, ITSOUS, NBNN, NBELEM, NBSOUS,NBE0
  61.      &     , JGM, JGN, IGEOM, ISOUS, IELEM
  62.      &     , NN1, NN2, NN3, NNC, NN4
  63.      &     , NFAC, NSOM, NTP, JG, LAST, LASTS
  64.      &     , LISFAC(4), LISSOM(4), NNS, NNOEU
  65.      &     , INOE
  66.      &     , LIFAC(3,4), MCHDIA
  67.       REAL*8 X1,Y1,X2,Y2,X3,Y3,XCEN,YCEN, SURF, VOLU
  68.      &     ,X4,Y4,SURF0,VOLU0,XCEN0,YCEN0,XC2D,YC2D,XC20,YC20
  69.       CHARACTER*8 TYPI
  70.       POINTEUR MELMAI.MELEME, MELCEN.MELEME, MELTFA.MELEME
  71.      &     , MELSOM.MELEME, MELFAC.MELEME, MELFAL.MELEME, MELFAP.MELEME
  72.       POINTEUR MCHVOL.MCHPOI, MPOVOL.MPOVAL
  73.      &     , MCHS2D.MCHPOI, MPOSUR.MPOVAL, MPOX2D.MPOVAL, MPOY2D.MPOVAL
  74.       POINTEUR MLRES.MLENTI, MLRESS.MLENTI, MLEFAC.MLENTI, MLETOF.MLENTI
  75. C
  76. C**** 'MAILLAGE'
  77. C
  78.       MELEME=MELEMQ
  79.       SEGACT MELEME
  80.       SEGINI, MELMAI=MELEME
  81.       NBS=MELEME.LISOUS(/1)
  82.       IF(NBS.EQ.0)NBS=1
  83.       NBREF=0
  84.       IF(NBS .EQ. 1)THEN
  85.          ITSOUS=MELEME.ITYPEL
  86.          IF(ITSOUS .EQ. 7)THEN
  87. C           TRI7 -> TRI3
  88.             MELMAI.ITYPEL=4
  89.             NBNN=3
  90.          ELSEIF(ITSOUS .EQ. 11)THEN
  91. C           QUA9 -> QUA4
  92.             MELMAI.ITYPEL=8
  93.             NBNN=4
  94.          ENDIF
  95.          NBELEM=MELEME.NUM(/2)
  96.          NBSOUS=0
  97.          SEGADJ MELMAI
  98.          NBE0=NBELEM
  99.       ELSE
  100.          NBE0=0
  101.          DO ISOUS=1,NBS,1
  102.             IPT1=MELEME.LISOUS(ISOUS)
  103.             SEGACT IPT1
  104.             ITSOUS=IPT1.ITYPEL
  105.             NBELEM=IPT1.NUM(/2)
  106.             IF(ITSOUS .EQ. 7)THEN
  107. C              TRI7 -> TRI3
  108.                NBNN=3
  109.                MELMAI.ITYPEL=4
  110.             ELSEIF(ITSOUS .EQ. 11)THEN
  111. C              QUA9 -> QUA4
  112.                MELMAI.ITYPEL=8
  113.                NBNN=4
  114.             ENDIF
  115.             NBSOUS=0
  116.             SEGINI IPT2
  117.             MELMAI.LISOUS(ISOUS)=IPT2
  118.             IPT2.ITYPEL=MELMAI.ITYPEL
  119.             MELMAI.ITYPEL=0
  120.             NBE0=NBE0+NBELEM
  121.             IPT1=MELEME.LISOUS(ISOUS)
  122.          ENDDO
  123.       ENDIF
  124.       CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI)
  125. C
  126. C**** 'CENTRE'
  127. C
  128.       NBELEM=NBE0
  129.       NBNN=1
  130.       NBSOUS=0
  131.       NBREF=0
  132.       SEGINI MELCEN
  133.       MELCEN.ITYPEL=1
  134.       CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN)
  135. C
  136. C**** 'XXVOLUM', 'XXSURF2D', 'XCEN2D', 'YCEN2D'
  137. C
  138.       TYPI='CENTRE  '
  139.       JGN=4
  140.       JGM=1
  141.       SEGINI MLMOTS
  142.       MLMOTS.MOTS(1)='SCAL'
  143.       CALL KRCHP1(TYPI,MELCEN,MCHVOL,MLMOTS)
  144.       IF(IERR.NE.0) GOTO 9999
  145.       CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHVOL)
  146.       IF(IERR.NE.0) GOTO 9999
  147.       CALL LICHT(MCHVOL,MPOVOL,TYPI,IGEOM)
  148.       IF(IERR.NE.0) GOTO 9999
  149. C     SEGACT MPOVOL
  150. C
  151.       CALL KRCHP1(TYPI,MELCEN,MCHS2D,MLMOTS)
  152.       IF(IERR.NE.0) GOTO 9999
  153.       CALL ECMO(MTAB,'XXSUR2D','CHPOINT',MCHS2D)
  154.       IF(IERR.NE.0) GOTO 9999
  155.       CALL LICHT(MCHS2D,MPOSUR,TYPI,IGEOM)
  156.       IF(IERR.NE.0) GOTO 9999
  157. C     SEGACT MPOSUR
  158. C
  159.       CALL KRCHP1(TYPI,MELCEN,MCHX2D,MLMOTS)
  160.       IF(IERR.NE.0) GOTO 9999
  161.       CALL ECMO(MTAB,'XCEN2D','CHPOINT',MCHX2D)
  162.       IF(IERR.NE.0) GOTO 9999
  163.       CALL LICHT(MCHX2D,MPOX2D,TYPI,IGEOM)
  164.       IF(IERR.NE.0) GOTO 9999
  165. C     SEGACT MPOX2D
  166. C
  167.       CALL KRCHP1(TYPI,MELCEN,MCHY2D,MLMOTS)
  168.       IF(IERR.NE.0) GOTO 9999
  169.       CALL ECMO(MTAB,'YCEN2D','CHPOINT',MCHY2D)
  170.       IF(IERR.NE.0) GOTO 9999
  171.       CALL LICHT(MCHY2D,MPOY2D,TYPI,IGEOM)
  172.       IF(IERR.NE.0) GOTO 9999
  173. C     SEGACT MPOY2D
  174.       SEGSUP MLMOTS
  175. C
  176. C     In KRIPAD
  177. C     SEGDES MELCEN
  178.       SEGACT MELCEN*MOD
  179. C
  180. C**** Filling
  181. C
  182.       NBE0=0
  183.       DO ISOUS=1,NBS,1
  184.          IF(NBS.EQ.1)THEN
  185.             IPT1=MELEME
  186.             IPT2=MELMAI
  187.          ELSE
  188.             IPT1=MELEME.LISOUS(ISOUS)
  189.             IPT2=MELMAI.LISOUS(ISOUS)
  190.          ENDIF
  191.          NBELEM=IPT1.NUM(/2)
  192.          ITSOUS=IPT1.ITYPEL
  193.          IF(ITSOUS .EQ. 7)THEN
  194. C           TRI
  195.             DO IELEM=1,NBELEM,1
  196.                NBE0=NBE0+1
  197.                NN1=IPT1.NUM(1,IELEM)
  198.                NN2=IPT1.NUM(3,IELEM)
  199.                NN3=IPT1.NUM(5,IELEM)
  200.                NNC=IPT1.NUM(7,IELEM)
  201. C
  202.                IPT2.NUM(1,IELEM)=NN1
  203.                IPT2.NUM(2,IELEM)=NN2
  204.                IPT2.NUM(3,IELEM)=NN3
  205.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  206.                MELCEN.NUM(1,NBE0)=NNC
  207.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  208. C
  209. C************* We compute the position of the center
  210. C              the 'XXVOLUM'
  211. C              the 'XXSUR2D'
  212. C
  213.                X1=XCOOR((NN1-1)*(IDIM+1)+1)
  214.                Y1=XCOOR((NN1-1)*(IDIM+1)+2)
  215.                X2=XCOOR((NN2-1)*(IDIM+1)+1)
  216.                Y2=XCOOR((NN2-1)*(IDIM+1)+2)
  217.                X3=XCOOR((NN3-1)*(IDIM+1)+1)
  218.                Y3=XCOOR((NN3-1)*(IDIM+1)+2)
  219.                CALL KDOM4B(X1,Y1,X2,Y2,X3,Y3,VOLU,SURF
  220.      &              ,XCEN,YCEN,XC2D,YC2D)
  221. C
  222.                MPOVOL.VPOCHA(NBE0,1)=VOLU
  223.                MPOSUR.VPOCHA(NBE0,1)=SURF
  224.                MPOX2D.VPOCHA(NBE0,1)=XC2D
  225.                MPOY2D.VPOCHA(NBE0,1)=YC2D
  226.                XCOOR((NNC-1)*(IDIM+1)+1)=XCEN
  227.                XCOOR((NNC-1)*(IDIM+1)+2)=YCEN
  228.             ENDDO
  229.          ELSEIF(ITSOUS .EQ. 11)THEN
  230. C          QUA
  231.             DO IELEM=1,NBELEM,1
  232.                NBE0=NBE0+1
  233.                NN1=IPT1.NUM(1,IELEM)
  234.                NN2=IPT1.NUM(3,IELEM)
  235.                NN3=IPT1.NUM(5,IELEM)
  236.                NN4=IPT1.NUM(7,IELEM)
  237.                NNC=IPT1.NUM(9,IELEM)
  238. C
  239.                IPT2.NUM(1,IELEM)=NN1
  240.                IPT2.NUM(2,IELEM)=NN2
  241.                IPT2.NUM(3,IELEM)=NN3
  242.                IPT2.NUM(4,IELEM)=NN4
  243.                IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM)
  244.                MELCEN.NUM(1,NBE0)=NNC
  245.                MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM)
  246. C
  247. C************* We compute the position of the center
  248. C              the 'XXVOLUM'
  249. C              the 'XXSUR2D'
  250. C
  251.                X1=XCOOR((NN1-1)*(IDIM+1)+1)
  252.                Y1=XCOOR((NN1-1)*(IDIM+1)+2)
  253.                X2=XCOOR((NN2-1)*(IDIM+1)+1)
  254.                Y2=XCOOR((NN2-1)*(IDIM+1)+2)
  255.                X3=XCOOR((NN3-1)*(IDIM+1)+1)
  256.                Y3=XCOOR((NN3-1)*(IDIM+1)+2)
  257.                X4=XCOOR((NN4-1)*(IDIM+1)+1)
  258.                Y4=XCOOR((NN4-1)*(IDIM+1)+2)
  259.                CALL KDOM4B(X1,Y1,X2,Y2,X4,Y4,VOLU0,SURF0,XCEN0,YCEN0
  260.      $              ,XC20,YC20)
  261.                CALL KDOM4B(X2,Y2,X3,Y3,X4,Y4,VOLU,SURF,XCEN,YCEN
  262.      $              ,XC2D,YC2D)
  263. C
  264.                MPOVOL.VPOCHA(NBE0,1)=VOLU+VOLU0
  265.                MPOSUR.VPOCHA(NBE0,1)=SURF+SURF0
  266.                MPOX2D.VPOCHA(NBE0,1)=((XC20*SURF0)+(XC2D*SURF))
  267.      $              /(SURF+SURF0)
  268.                MPOY2D.VPOCHA(NBE0,1)=((YC20*SURF0)+(YC2D*SURF))
  269.      $              /(SURF+SURF0)
  270.                XCOOR((NNC-1)*(IDIM+1)+1)=((XCEN0*VOLU0)+(XCEN*VOLU))
  271.      $              /(VOLU+VOLU0)
  272.                XCOOR((NNC-1)*(IDIM+1)+2)=((YCEN0*VOLU0)+(YCEN*VOLU))
  273.      $              /(VOLU+VOLU0)
  274.             ENDDO
  275.          ENDIF
  276.          SEGDES IPT2
  277.       ENDDO
  278. C
  279.       IF(NBS.NE.1)THEN
  280.          SEGDES MELMAI
  281.       ENDIF
  282. C
  283.       SEGDES MPOSUR
  284.       SEGDES MPOVOL
  285.       SEGDES MELCEN
  286. C
  287. C     MELEME et ses "fils" sont toujours actifs
  288. C
  289. C**** We create ELTFA, FACE and SOMMET
  290. C     N.B. The position of the noeud belonging to the FACE
  291. C          is not correct
  292. C
  293.       SEGINI, MELTFA=MELEME
  294.       NBREF=0
  295.       IF(NBS .EQ. 1)THEN
  296.          ITSOUS=MELEME.ITYPEL
  297.          IF(ITSOUS .EQ. 7)THEN
  298. C           TRI3
  299.             NBNN=3
  300.             MELTFA.ITYPEL=4
  301. C           ELTFA TRI3
  302.          ELSEIF(ITSOUS .EQ. 11)THEN
  303. C           QUA4
  304.             NBNN=4
  305.             MELTFA.ITYPEL=8
  306. C           ELTFA QUA4
  307.          ENDIF
  308.          NBELEM=MELEME.NUM(/2)
  309.          NBSOUS=0
  310.          SEGADJ MELTFA
  311.       ELSE
  312.          DO ISOUS=1,NBS,1
  313.             IPT1=MELEME.LISOUS(ISOUS)
  314.             NBELEM=IPT1.NUM(/2)
  315.             ITSOUS=IPT1.ITYPEL
  316.             IF(ITSOUS .EQ. 7)THEN
  317. C              TRI3
  318.                NBNN=3
  319.                MELTFA.ITYPEL=4
  320.             ELSEIF(ITSOUS .EQ. 11)THEN
  321. C              QUA4
  322.                NBNN=4
  323.                MELTFA.ITYPEL=8
  324. C              ELTFA QUA4
  325.             ENDIF
  326.             NBSOUS=0
  327.             SEGINI IPT2
  328.             MELTFA.LISOUS(ISOUS)=IPT2
  329. C
  330.             IPT2.ITYPEL=MELTFA.ITYPEL
  331.             MELTFA.ITYPEL=0
  332.          ENDDO
  333.       ENDIF
  334. C
  335. C**** We fill ELTFA
  336. C     We also count:
  337. C     NFAC  = number of non-triangular faces
  338. C     NSOM  = number of SOMMET
  339. C
  340.       NTP=nbpts
  341.       JG=NTP
  342.       NFAC=0
  343.       NSOM=0
  344.  
  345.       LAST=-1
  346.       SEGINI MLRES
  347.       LASTS=-1
  348.       SEGINI MLRESS
  349. C     LAST+MLRES = chaining list to find the faces
  350. C     LASTS+MLRESS = chaining list to find the sommet
  351.  
  352.       DO ISOUS=1,NBS,1
  353.          IF(NBS.EQ.1) THEN
  354.             IPT1=MELEME
  355.             IPT2=MELTFA
  356.          ELSE
  357.             IPT1=MELEME.LISOUS(ISOUS)
  358.             IPT2=MELTFA.LISOUS(ISOUS)
  359.          ENDIF
  360. C
  361.          NBELEM=IPT1.NUM(/2)
  362.          ITSOUS=IPT1.ITYPEL
  363.          IF(ITSOUS .EQ. 7)THEN
  364. C          TRI (2D)
  365.             LISFAC(1)=2
  366.             LISFAC(2)=4
  367.             LISFAC(3)=6
  368.             LISSOM(1)=1
  369.             LISSOM(2)=3
  370.             LISSOM(3)=5
  371.             NNS=3
  372.             NNOEU=3
  373.          ELSEIF(ITSOUS .EQ. 11)THEN
  374. C           QUA (2D)
  375.             LISFAC(1)=2
  376.             LISFAC(2)=4
  377.             LISFAC(3)=6
  378.             LISFAC(4)=8
  379.             LISSOM(1)=1
  380.             LISSOM(2)=3
  381.             LISSOM(3)=5
  382.             LISSOM(4)=7
  383.             NNS=4
  384.             NNOEU=4
  385.          ENDIF
  386. C
  387.          DO IELEM=1,NBELEM,1
  388.             DO INOE=1,NNOEU,1
  389.                NN1=IPT1.NUM(LISFAC(INOE),IELEM)
  390.                IPT2.NUM(INOE,IELEM)=NN1
  391.                IF(MLRES.LECT(NN1) .EQ. 0)THEN
  392.                   NFAC=NFAC+1
  393.                   MLRES.LECT(NN1)=LAST
  394.                   LAST=NN1
  395.                ENDIF
  396.             ENDDO
  397.             DO INOE=1,NNS,1
  398.                NN1=IPT1.NUM(LISSOM(INOE),IELEM)
  399.                IF(MLRESS.LECT(NN1) .EQ. 0)THEN
  400.                   NSOM=NSOM+1
  401.                   MLRESS.LECT(NN1)=LASTS
  402.                   LASTS=NN1
  403.                ENDIF
  404.             ENDDO
  405.          ENDDO
  406. C
  407.          SEGDES IPT2
  408. C
  409.       ENDDO
  410.       IF(NBS. NE. 1)  SEGDES MELTFA
  411.       CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA)
  412.       IF(IERR .NE. 0) GOTO 9999
  413. C
  414. C******** Creation of SOMMET
  415. C
  416.       NBELEM=NSOM
  417.       NBNN=1
  418.       NBSOUS=0
  419.       NBREF=0
  420.       SEGINI MELSOM
  421.       MELSOM.ITYPEL=1
  422.       DO IELEM=1,NSOM,1
  423.          MELSOM.NUM(1,IELEM)=LASTS
  424.          LASTS=MLRESS.LECT(LASTS)
  425.       ENDDO
  426.       IF(LASTS .NE. -1)THEN
  427.          WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  428.          CALL ERREUR(5)
  429.       ENDIF
  430.       call crech1(melsom,1)
  431.       SEGDES MELSOM
  432.       CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM)
  433.       SEGSUP MLRESS
  434. C
  435. C**** Creation of FACE
  436. C
  437.       NBELEM=NFAC
  438.       NBNN=1
  439.       NBSOUS=0
  440.       NBREF=0
  441.       SEGINI MELFAC
  442.       MELFAC.ITYPEL=1
  443.       DO IELEM=1,NFAC,1
  444.          MELFAC.NUM(1,IELEM)=LAST
  445.          LAST=MLRES.LECT(LAST)
  446.       ENDDO
  447.       IF(LAST .NE. -1)THEN
  448.          WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  449.          CALL ERREUR(5)
  450.       ENDIF
  451.       SEGDES MELFAC
  452.       SEGSUP MLRES
  453.       CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC)
  454. C
  455. C******* Creation of FACEL and FACEP
  456. C
  457.       CALL KRIPAD(MELFAC,MLEFAC)
  458. C     SEGINI MLEFAC
  459.       JG=NFAC
  460.       SEGINI MLETOF
  461. C
  462. C     MLETOF.LECT(I1) = how many times has the i-th face of MELFAP
  463. C                       already been touched?
  464. C
  465.       NBELEM=NFAC
  466.       NBNN=3
  467.       NBSOUS=0
  468.       NBREF=0
  469.       SEGINI MELFAL
  470.       MELFAL.ITYPEL=3
  471. C
  472. C     FACEP is a SEG3
  473. C
  474.       NBELEM=NFAC
  475.       NBNN=3
  476.       NBSOUS=0
  477.       NBREF=0
  478.       SEGINI MELFAP
  479.       MELFAP.ITYPEL=3
  480. C
  481.       DO ISOUS=1,NBS,1
  482. C
  483. C********** Loop on the elementary mesh of the QUAF
  484. C
  485.          IF(NBS.EQ.1) THEN
  486.             IPT1=MELEME
  487.          ELSE
  488.             IPT1=MELEME.LISOUS(ISOUS)
  489.          ENDIF
  490. C
  491.          ITSOUS=IPT1.ITYPEL
  492.          IF(ITSOUS .EQ. 7)THEN
  493. C           TRI (2D)
  494.             LIFAC(1,1)=2
  495.             LIFAC(2,1)=1
  496.             LIFAC(3,1)=3
  497.             LIFAC(1,2)=4
  498.             LIFAC(2,2)=3
  499.             LIFAC(3,2)=5
  500.             LIFAC(1,3)=6
  501.             LIFAC(2,3)=5
  502.             LIFAC(3,3)=1
  503. C           Here we put the center point in LISSOM
  504.             LISSOM(1)=7
  505.             NNOEU=3
  506. C
  507.          ELSEIF(ITSOUS .EQ. 11)THEN
  508. C          QUA (2D)
  509.             LIFAC(1,1)=2
  510.             LIFAC(2,1)=1
  511.             LIFAC(3,1)=3
  512.             LIFAC(1,2)=4
  513.             LIFAC(2,2)=3
  514.             LIFAC(3,2)=5
  515.             LIFAC(1,3)=6
  516.             LIFAC(2,3)=5
  517.             LIFAC(3,3)=7
  518.             LIFAC(1,4)=8
  519.             LIFAC(2,4)=7
  520.             LIFAC(3,4)=1
  521.             LISSOM(1)=9
  522.             NNOEU=4
  523.          ENDIF
  524. C
  525.          NBELEM=IPT1.NUM(/2)
  526.          DO IELEM=1,NBELEM,1
  527. C           NNOEU = number of quagrangular elements
  528.             DO INOE=1,NNOEU,1
  529. C              NN1 is the global number of the face
  530. C              NN2 is the local number of the face in the MELEME
  531. C                 'FACE'
  532. C
  533.                NN1=IPT1.NUM(LIFAC(1,INOE),IELEM)
  534.                NN2=MLEFAC.LECT(NN1)
  535.                IF(MLETOF.LECT(NN2).EQ.0)THEN
  536. C
  537. C                    MLETOF.LECT(NN2) = how many times the face NN2 has
  538. C                    been touched?
  539. C
  540.                   MLETOF.LECT(NN2)=1
  541.                   MELFAL.NUM(2,NN2)=NN1
  542.                   MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  543.                   MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  544.                   MELFAP.NUM(1,NN2)=IPT1.NUM(LIFAC(2,INOE),IELEM)
  545.                   MELFAP.NUM(2,NN2)=IPT1.NUM(LIFAC(3,INOE),IELEM)
  546.                   MELFAP.NUM(3,NN2)=NN1
  547.                ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN
  548.                   MLETOF.LECT(NN2)=2
  549.                   MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM)
  550.                ELSE
  551.                   WRITE(IOIMP,*) 'Subroutine kdom10.eso'
  552.                   CALL ERREUR(5)
  553.                ENDIF
  554.             ENDDO
  555.          ENDDO
  556.       ENDDO
  557.       SEGDES MELFAL
  558.       SEGDES MELFAP
  559.       SEGSUP MLETOF
  560.       SEGSUP MLEFAC
  561.       CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL)
  562.       IF(IERR .NE. 0) GOTO 9999
  563.       CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP)
  564.       IF(IERR .NE. 0) GOTO 9999
  565.       IF(NBS.NE.1)THEN
  566.          SEGDES MELEME
  567.       ENDIF
  568. C
  569. C**** We have to create
  570. C     'XXSURFAC'
  571. C     'XXNORMAF'
  572. C     'MATROT'
  573. C     and to put the face centre in the right position!
  574. C
  575.       CALL KDOM4C(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR)
  576.       IF(IERR.NE.0)GOTO 9999
  577. C
  578.       CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU)
  579.       IF(IERR.NE.0) GOTO 9999
  580.       CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO)
  581.       IF(IERR.NE.0) GOTO 9999
  582.       CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR)
  583.       IF(IERR.NE.0) GOTO 9999
  584. C
  585. C**** Finally, we compute XXDIEMIN
  586. C
  587.       CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  588.       IF(IERR.NE.0) GOTO 9999
  589.       CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA)
  590.       IF(IERR.NE.0) GOTO 9999
  591. C
  592.  9999 RETURN
  593.       END
  594.  
  595.  
  596.  
  597.  
  598.  
  599.  
  600.  

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