Télécharger isova5.eso

Retour à la liste

Numérotation des lignes :

  1. C ISOVA5 SOURCE PV 20/03/24 21:18:24 10554
  2. SUBROUTINE ISOVA5(NEWNOD,ELEMS,ITYPL)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : ISOVA5
  7. C DESCRIPTION : La pile NEWNOD contient généralement des noeuds
  8. * géométriquement confondus : on les élimine.
  9. * Puis, on incrémente le segment MCOORD avec le nouveaux
  10. * noeuds non géométriquement confondus
  11. * et on met à jour les piles d'éléments.
  12. C
  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, 15/09/2014, version initiale
  20. C HISTORIQUE : v1, 15/09/2014, création
  21. C HISTORIQUE :
  22. C***********************************************************************
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCGEOME
  27. -INC SMLENTI
  28. -INC CCREEL
  29. -INC SMCOORD
  30. *
  31. * Segments ajustables 1D contenant les noeuds des éléments créés ainsi
  32. * que leur couleur
  33. * ELEM(1) contient des POI1
  34. * ELEM(2) contient des SEG2
  35. * ELEM(3) contient des TRI3
  36. * ELEM(4) contient des TET4
  37. * ELEM(5) contient des PYR5
  38. * ELEM(6) contient des PRI6
  39. * ELEM(7) contient des QUA4
  40. *
  41. PARAMETER (NTYEL=7)
  42. SEGMENT ELEMS
  43. POINTEUR ELEM(NTYEL).MLENTI
  44. ENDSEGMENT
  45. * Défini dans isova1
  46. INTEGER ITYPL(NTYEL)
  47. *
  48. * Pile des nouveaux noeuds
  49. SEGMENT NEWNOD
  50. INTEGER NNOD
  51. INTEGER NOEINF(MAXNOD)
  52. INTEGER NOESUP(MAXNOD)
  53. REAL*8 COEINF(MAXNOD)
  54. ENDSEGMENT
  55. *
  56. segment newnum(nnod)
  57. *
  58. SEGMENT ICPR(nbpts)
  59. segment inode(ino)
  60. segment jelnum(imaxel,ino)
  61. segment kelnum(imaxel,ino)
  62. segment xelnum(imaxel,ino)
  63. *
  64. LOGICAL LFOUND
  65. *
  66. * Executable statements
  67. *
  68. **********************************************************************
  69. * Traitement des noeuds redondants
  70. **********************************************************************
  71. *
  72. * Trouver les noeuds redondants dans NEWNOD
  73. *
  74. * Création d'une numérotation locale
  75. segini icpr
  76. ino=0
  77. do jnod=1,nnod
  78. ia=noesup(jnod)
  79. if(icpr(ia).eq.0) then
  80. ino=ino+1
  81. icpr(ia)=ino
  82. endif
  83. enddo
  84. * on compte combien de segment touche un noeud
  85. segini inode
  86. do jnod=1,nnod
  87. ia=noesup(jnod)
  88. ib=icpr(ia)
  89. inode(ib)=inode(ib)+1
  90. enddo
  91. imaxel=0
  92. do i=1,ino
  93. imaxel=max(imaxel,inode(i))
  94. * inode(i)=0
  95. enddo
  96. segsup inode
  97. * on crée les noeuds uniques et une nouvelle numérotation
  98. * dans newnum(jnod) : si newnum(jnod)=knod>0 le noeud jnod est à garder
  99. * et est numéroté knod dans la nouvelle num
  100. * si newnum(jnod)=-knod<0 le noeud jnod est à
  101. * supprimer, il est remplacé par knod dans la
  102. * nouvelle num
  103. knod=0
  104. ired=0
  105. segini jelnum
  106. segini kelnum
  107. segini xelnum
  108. segini newnum
  109. do jnod=1,nnod
  110. ia=noesup(jnod)
  111. ib=icpr(ia)
  112. lfound=.false.
  113. do j=1,imaxel
  114. if (jelnum(j,ib).eq.0) then
  115. jelnum(j,ib)=noeinf(jnod)
  116. xelnum(j,ib)=coeinf(jnod)
  117. knod=knod+1
  118. kelnum(j,ib)=knod
  119. newnum(jnod)=knod
  120. goto 103
  121. elseif (jelnum(j,ib).eq.noeinf(jnod)) then
  122. * if (xelnum(j,ib).eq.coeinf(jnod)) then
  123. * On met xzprec*10.D0 pour mimer le XTOL mis dans isoval.eso
  124. if (abs(xelnum(j,ib)-coeinf(jnod)).le.(xzprec*10.d0))
  125. $ then
  126. lfound=.true.
  127. newnum(jnod)=-kelnum(j,ib)
  128. goto 103
  129. endif
  130. endif
  131. enddo
  132. 103 continue
  133. if (lfound) then
  134. ired=ired+1
  135. else
  136. if (ired.gt.0) then
  137. noeinf(jnod-ired)=noeinf(jnod)
  138. noesup(jnod-ired)=noesup(jnod)
  139. coeinf(jnod-ired)=coeinf(jnod)
  140. endif
  141. endif
  142. enddo
  143. segsup jelnum
  144. segsup kelnum
  145. segsup xelnum
  146. if (ired.gt.0) then
  147. *dbg write(ioimp,*) 'il y a ired=',ired,' noeuds a eliminer'
  148. *dbg2 write(ioimp,*) 'Nouvelle numerotation :'
  149. *dbg2 write(ioimp,*) (newnum(i),i=1,newnum(/1))
  150. nnod=nnod-ired
  151. maxnod=nnod
  152. segadj,newnod
  153. *
  154. * Passage dans la nouvelle numérotation dans les piles
  155. *
  156. do ipil=1,7
  157. mlenti=elem(ipil)
  158. nnode=nbnne(itypl(ipil))
  159. jg=lect(/1)
  160. ng=jg/(nnode+1)
  161. do ig=1,ng
  162. do iloc=1,nnode
  163. idx=(nnode+1)*(ig-1)+iloc
  164. * write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
  165. * write(ioimp,*) ' idx=',idx
  166. inod=lect(idx)
  167. * esope n'aime pas trop la forme suivante
  168. * if (inod.le.0) lect(idx)=-abs(newnum(-inod))
  169. if (inod.le.0) lect(idx)=-abs(newnum(0-inod))
  170. enddo
  171. enddo
  172. enddo
  173. endif
  174. segsup newnum
  175. *
  176. * Création des nouveaux noeuds dans MCOORD et mise à jour
  177. * des numéros dans les piles d'éléments
  178. *
  179. SEGACT MCOORD*MOD
  180. IDIM1=IDIM+1
  181. NBANC=nbpts
  182. *dbg write(ioimp,*) 'Nombre de nouveaux/anciens noeuds=',NNOD,' ',NBANC
  183. NBPTS=NBANC+NNOD
  184. SEGADJ,MCOORD
  185. DO JNOD=1,NNOD
  186. num1=noeinf(jnod)
  187. num2=noesup(jnod)
  188. x1=coeinf(jnod)
  189. x2=1.D0-x1
  190. DO II=1,IDIM+1
  191. XCOOR((NBANC+JNOD-1)*IDIM1+II)=
  192. $ (XCOOR((NUM2-1)*IDIM1+II)*X2)+
  193. $ (XCOOR((NUM1-1)*IDIM1+II)*X1)
  194. ENDDO
  195. ENDDO
  196. SEGACT MCOORD
  197. SEGSUP NEWNOD
  198. *
  199. * Mise à jour des noeuds dans les piles (cette étape peut être faite
  200. *juste avant la modif de MCOORD, on la garde pour clarté).
  201. *
  202. do ipil=1,7
  203. mlenti=elem(ipil)
  204. nnode=nbnne(itypl(ipil))
  205. jg=lect(/1)
  206. ng=jg/(nnode+1)
  207. do ig=1,ng
  208. do iloc=1,nnode
  209. idx=(nnode+1)*(ig-1)+iloc
  210. * write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
  211. * write(ioimp,*) ' idx=',idx
  212. inod=lect(idx)
  213. if (inod.le.0) lect(idx)=nbanc-inod
  214. enddo
  215. enddo
  216. enddo
  217. *
  218. * End of subroutine ISOVA5
  219. *
  220. END
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  

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