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

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