Télécharger isova5.eso

Retour à la liste

Numérotation des lignes :

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

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