Télécharger isova1.eso

Retour à la liste

Numérotation des lignes :

  1. C ISOVA1 SOURCE PV 20/03/30 21:20:08 10567
  2. SUBROUTINE ISOVA1(MCHELM,XISO,XTOL,IOPT,MELEME)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : ISOVA1
  7. C DESCRIPTION : Construit le maillage d'une isovaleur d'un champ par
  8. C éléments
  9. C
  10. * IOPT=-1 EGIN
  11. * IOPT=0 EGAL (par défaut)
  12. * IOPT=1 EGSU
  13. C
  14. C
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C VERSION : v1, 17/12/2008, version initiale
  20. C HISTORIQUE : v1, 17/12/2008, création
  21. C HISTORIQUE : 30/07/2014, sg: ajout des options EGIN EGSU
  22. C ne pas créer de noeuds et d'éléments en multiples
  23. C exemplaires.
  24. C
  25. C
  26. C HISTORIQUE :
  27. C***********************************************************************
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCGEOME
  32. -INC CCREEL
  33. -INC SMCOORD
  34. -INC SMELEME
  35. -INC SMCHAML
  36. -INC SMLENTI
  37. *
  38. * Segments ajustables 1D contenant les noeuds des éléments créés ainsi
  39. * que leur couleur
  40. * ELEM(1) contient des POI1
  41. * ELEM(2) contient des SEG2
  42. * ELEM(3) contient des TRI3
  43. * ELEM(4) contient des TET4
  44. * ELEM(5) contient des PYR5
  45. * ELEM(6) contient des PRI6
  46. * ELEM(7) contient des QUA4
  47. *
  48. PARAMETER (NTYEL=7)
  49. SEGMENT ELEMS
  50. POINTEUR ELEM(NTYEL).MLENTI
  51. ENDSEGMENT
  52. SEGMENT MELEMS
  53. POINTEUR IPT(NTYEL).MELEME
  54. ENDSEGMENT
  55. *
  56. * Pile des nouveaux noeuds
  57. SEGMENT NEWNOD
  58. INTEGER NNOD
  59. INTEGER NOEINF(MAXNOD)
  60. INTEGER NOESUP(MAXNOD)
  61. REAL*8 COEINF(MAXNOD)
  62. ENDSEGMENT
  63. *
  64. segment newnum(nnod)
  65. *
  66. SEGMENT ICPR(nbpts)
  67. segment inode(ino)
  68. segment jelnum(imaxel,ino)
  69. segment kelnum(imaxel,ino)
  70. segment xelnum(imaxel,ino)
  71. *
  72. CHARACTER*8 MCHA
  73. INTEGER IMPR,IRET
  74. LOGICAL LFOUND
  75. *
  76. INTEGER ITYPL(NTYEL)
  77. DATA ITYPL/1,2,4,23,25,16,8/
  78. *
  79. * Executable statements
  80. *
  81. IMPR=0
  82. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans isova1.eso'
  83. *
  84. * Initialisation des objets possiblement créés et de la pile
  85. * des nouveaux noeuds
  86. *
  87. SEGINI ELEMS
  88. DO ITYEL=1,NTYEL
  89. JG=0
  90. SEGINI MLENTI
  91. ELEM(ITYEL)=MLENTI
  92. ENDDO
  93. MAXNOD=0
  94. SEGINI NEWNOD
  95. *
  96. * Parcours du CHAMELEM
  97. *
  98. SEGACT MCHELM
  99. N1=IMACHE(/1)
  100. DO I1=1,N1
  101. ITYCHA=INFCHE(I1,6)
  102. IF (ITYCHA.NE.1) THEN
  103. MOTERR(1:16)='NOEUDS '
  104. * 291 2
  105. *Pas de MCHAML de type %m1:16 trouvé
  106. CALL ERREUR(291)
  107. RETURN
  108. ENDIF
  109. MELEME=IMACHE(I1)
  110. SEGACT MELEME
  111. MCHAML=ICHAML(I1)
  112. SEGACT MCHAML
  113. CALL ISOVA2(MELEME,MCHAML,XISO,XTOL,IOPT,NEWNOD,ELEMS,ITYPL)
  114. IF (IERR.NE.0) RETURN
  115. SEGDES MCHAML
  116. SEGDES MELEME
  117. ENDDO
  118. SEGDES MCHELM
  119. *
  120. * La pile NEWNOD contient généralement des noeuds géométriquement
  121. * confondus : on les élimine. Puis, on incrémente le segment MCOORD
  122. * avec le nouveaux noeuds non géométriquement confondus
  123. * et on met à jour les piles d'éléments.
  124. *
  125. CALL ISOVA5(NEWNOD,ELEMS,ITYPL)
  126. IF (IERR.NE.0) RETURN
  127. *
  128. * Les piles d'éléments peuvent contenir des informations redondantes :
  129. * - dans une pile d'éléments, plusieurs fois le même
  130. * - dans la pile des POI1, des noeuds déjà présents dans les piles
  131. * de SEG2, TRI3, TET4, PYR5, PRI6, QUA4
  132. * - dans la pile des SEG2, des segments déjà présents dans les piles
  133. * de TRI3, TET4, PYR5, PRI6, QUA4
  134. * - dans la pile des TRI3, des faces dèjà présentes dans la pile des
  135. * TET4
  136. * On réduit les piles de manière adéquate.
  137. *
  138. CALL ISOVA6(ELEMS,ITYPL)
  139. IF (IERR.NE.0) RETURN
  140. *
  141. * Transformation des segments ajustables en MELEME
  142. *
  143. SEGINI MELEMS
  144. NSOUT=0
  145. NBSOUS=0
  146. NBREF=0
  147. DO ITYEL=1,NTYEL
  148. MLENTI=ELEM(ITYEL)
  149. JG=LECT(/1)
  150. IF (JG.GT.0) THEN
  151. NSOUT=NSOUT+1
  152. ITYP=ITYPL(ITYEL)
  153. NBNN=NBNNE(ITYP)
  154. NBNN1=NBNN+1
  155. NBELEM=JG/NBNN1
  156. SEGINI MELEME
  157. ITYPEL=ITYP
  158. DO IELEM=1,NBELEM
  159. DO INN=1,NBNN
  160. NUM(INN,IELEM)=LECT((IELEM-1)*NBNN1+INN)
  161. ENDDO
  162. ICOLOR(IELEM)=LECT(IELEM*NBNN1)
  163. ENDDO
  164. SEGDES MELEME
  165. MELEMS.IPT(ITYEL)=MELEME
  166. ENDIF
  167. SEGSUP MLENTI
  168. ENDDO
  169. SEGSUP ELEMS
  170. *
  171. IF (NSOUT.EQ.1) THEN
  172. DO ITYEL=1,NTYEL
  173. IPT1=IPT(ITYEL)
  174. IF (IPT1.NE.0) THEN
  175. MELEME=IPT1
  176. ENDIF
  177. ENDDO
  178. ELSE
  179. * Traite aussi le cas maillage vide (NSOUT=0)
  180. NBNN=0
  181. NBELEM=0
  182. NBREF=0
  183. NBSOUS=NSOUT
  184. NBREF=0
  185. SEGINI MELEME
  186. ISOUS=0
  187. DO ITYEL=1,NTYEL
  188. IPT1=IPT(ITYEL)
  189. IF (IPT1.NE.0) THEN
  190. ISOUS=ISOUS+1
  191. LISOUS(ISOUS)=IPT1
  192. ENDIF
  193. ENDDO
  194. SEGDES MELEME
  195. ENDIF
  196. SEGSUP MELEMS
  197. RETURN
  198. *
  199. * End of subroutine ISOVA1
  200. *
  201. END
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  

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