Télécharger la plaquette Cast3M


fr en

Télécharger kdom2a.eso

Retour à la liste

Numérotation des lignes : 

kdom2a

  1. C KDOM2A    SOURCE    OF166741  24/12/13    21:16:01     12097          
  2.       SUBROUTINE KDOM2A(MTAB,MELEMQ)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET            :  CASTEM 2000
  7. C
  8. C NOM               :  KDOM2A
  9. C
  10. C DESCRIPTION       :  Subroutine called by KDOM1
  11. C                      Axial-symmetric case
  12. C
  13. C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  14. C
  15. C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/LTMF
  16. C
  17. C************************************************************************
  18. C
  19. C E/S               : MTAB   : domaine table
  20. C                     MELEMQ : QUAF mesh
  21. C
  22. C************************************************************************
  23. C
  24. C Created the 24/02/04
  25. C
  26.       IMPLICIT INTEGER(I-N)
  27.       INTEGER MTAB, MELEMQ, NBSOUS, ISOUS
  28.       LOGICAL LOSEG3, LOTRI7, LOQUA9
  29. C
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMELEME
  34. C
  35. C Elements allowed are SEG3, TRI7, QUA9
  36. C ITYPEL                3      7    11
  37. C They can be referred just once
  38. C We define LISTSO s.t.
  39. C
  40.       LOSEG3=.FALSE.
  41.       LOTRI7=.FALSE.
  42.       LOQUA9=.FALSE.
  43. C
  44.       MELEME=MELEMQ
  45.       SEGACT MELEME
  46.       NBSOUS=MELEME.LISOUS(/1)
  47.       IF(NBSOUS .EQ. 0) NBSOUS=1
  48.       DO ISOUS=1,NBSOUS,1
  49.          IF(NBSOUS .NE. 1)THEN
  50.             IPT1=MELEME.LISOUS(ISOUS)
  51.             SEGACT IPT1
  52.          ELSE
  53.             IPT1=MELEME
  54.          ENDIF
  55. C
  56.          IF(IPT1.ITYPEL .EQ. 3)THEN
  57.             IF(NBSOUS .NE. 1)THEN
  58. C              SEG3 with TRI7 or QUA9 -> Error
  59. C              2 SEG3 in the same mesh -> Error
  60. C              Note that in that case IPT1=MELEMQ
  61.                WRITE(IOIMP,*) 'Subroutine kdom2a'
  62.                WRITE(IOIMP,*) 'Mesh type not recognized'
  63.                CALL ERREUR(5)
  64.             ENDIF
  65.             LOSEG3=.TRUE.
  66. C
  67. C********** SEG3
  68. C
  69. C           We compute
  70. C           MTAB . 'XXVOLUM'
  71. C           MTAB . 'CENTRE'
  72. C           and we change the positions of the central points in MELEMQ
  73. C
  74.             CALL KDOM3A(MTAB,IPT1)
  75.             IF(IERR.NE.0)GOTO 9999
  76. C
  77.          ELSEIF(IPT1.ITYPEL .EQ. 7)THEN
  78. C
  79. C********** TRI7
  80. C
  81.             IF(LOTRI7)THEN
  82. C              Elt already referred
  83.                WRITE(IOIMP,*) 'Subroutine kdom2a'
  84.                WRITE(IOIMP,*) 'Mesh type not recognized'
  85.                CALL ERREUR(5)
  86.                GOTO 9999
  87.             ENDIF
  88.             LOTRI7=.TRUE.
  89. C
  90.          ELSEIF(IPT1.ITYPEL .EQ. 11)THEN
  91. C
  92. C********** QUA9
  93. C
  94.             IF(LOQUA9)THEN
  95. C              Elt already referred
  96.                WRITE(IOIMP,*) 'Subroutine kdom2a'
  97.                WRITE(IOIMP,*) 'Mesh type not recognized'
  98.                CALL ERREUR(5)
  99.                GOTO 9999
  100.             ENDIF
  101.             LOQUA9=.TRUE.
  102.          ELSE
  103. C              Elt already referred
  104.                WRITE(IOIMP,*) 'Subroutine kdom2a'
  105.                WRITE(IOIMP,*) 'Mesh type not recognized'
  106.                CALL ERREUR(5)
  107.                GOTO 9999
  108.          ENDIF
  109.          SEGDES IPT1
  110.       ENDDO
  111. C
  112.       IF(NBSOUS .NE. 1) SEGDES MELEME
  113. C
  114. C**** 2 cases:
  115. C     SEG3 -> Everything is done
  116. C     TRI7/QUA9 -> We have checked that the meshes
  117. C                  is not bizarre
  118. C                  Everything is to do
  119. C
  120.       IF(.NOT. LOSEG3)THEN
  121.          CALL KDOM4A(MTAB,MELEMQ)
  122.          IF(IERR .NE. 0)GOTO 9999
  123.       ENDIF
  124. C
  125.  9999 RETURN
  126. C
  127.       END
  128.  
  129.  
  130.  
  131.  
  132.  

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