Télécharger ajouel.eso

Retour à la liste

Numérotation des lignes :

  1. C AJOUEL SOURCE CB215821 17/07/25 21:15:03 9519
  2. C
  3. SUBROUTINE AJOUEL(NODE,NBNODE,ityp1,IMELE,IEL)
  4. C--------------------------------------------------------------
  5. C
  6. C FONCTION :
  7. C Verifie l'existence d'un element (defini par ses noeuds)
  8. C en tenant compte de l'eventuelle permutation des noeuds
  9. C et Ajoute cet element au maillage si non existence
  10. C
  11. C NODE : ENTREE : Tableau des noeudsde dimension NBNODE
  12. C ityp1 : ENTREE : ITYPEL (type d'element)
  13. C IMELE : E/S : Pointeur vers MELEME (actif et modifiable en E/S)
  14. C IEL : ENTREE : Numero de l element qu'on propose de créer
  15. C IEL : SORTIE : Numero de l element effectivement créé ou retrouvé
  16. C
  17. C APPELE PAR : INTGEO
  18. C
  19. C CREATION : BP 2012/09/11
  20. C
  21. C--------------------------------------------------------------
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8(A-H,O-Z)
  24. INTEGER NODE(NBNODE)
  25. SEGMENT IVU(NBNODE)
  26. C
  27. -INC CCOPTIO
  28. -INC SMELEME
  29.  
  30. c write(ioimp,fmt="('ajouel(',I5,I5,I3,I3,I7,I3)")
  31. c &NODE(1),NODE(2),NBNODE,ityp1,IMELE,IEL
  32.  
  33. C--------------------------------------------------------------
  34. C PRELIMINAIRES et initialisation
  35.  
  36. SEGINI,IVU
  37. c on commence par le 1er noeud a cherche
  38. inode=1
  39. nono = NODE(inode)
  40.  
  41. C--------------------------------------------------------------
  42. C ON RECHERCHE LE POINT (idem ELIM)
  43.  
  44. c maillage a verifier (actif et modifiable en entrée)
  45. IPT1 = IMELE
  46. c segact,IPT1
  47.  
  48. NBSOUS = IPT1.LISOUS(/1)
  49. c dans le cas d un meleme complexe,
  50. c==== il faut boucler sur les differents type d elements ====
  51. DO 100 ISOUS=1,max(1,NBSOUS)
  52.  
  53. if (NBSOUS.ne.0) then
  54. MELEME=IPT1.LISOUS(isous)
  55. c segact,meleme
  56. else
  57. MELEME=IPT1
  58. endif
  59.  
  60. if(ITYPEL.ne.ityp1) goto 100
  61. NBNN = NUM(/1)
  62. NBEL = NUM(/2)
  63. C ici MELEME est un maillage simple (NSOUS = 0)
  64. NBSOUS = LISOUS(/1)
  65. NBREF = LISREF(/1)
  66. c write(ioimp,*) 'ajouel: on a trouvé le bon itypel=',ityp1
  67. c & ,' associe au maillage de dim=',NBNN,NBEL
  68.  
  69. if(NBNN.ne.NBNODE) then
  70. c goto 100
  71. c write(ioimp,*)'ajouel: ITYPEL et nombre de noeuds incompatibles'
  72. call erreur(21)
  73. endif
  74. c on a le bon nombre de noeuds :
  75. c on cherche si l element fourni existe deja
  76.  
  77. c write(ioimp,*)'ajouel: on cherche le ',inode,'ieme noeud=',nono
  78.  
  79.  
  80. c boucle sur les element du maillage
  81. DO 71 J=1,NBEL
  82.  
  83. c on remet a zero si IVU a bougé
  84. if(inode.gt.1) then
  85. do iii=1,(inode-1)
  86. IVU(iii)=0
  87. enddo
  88. c on commence par le 1er noeud
  89. inode=1
  90. nono = NODE(inode)
  91. endif
  92.  
  93. c boucle sur les noeuds
  94. 72 I=0
  95. 73 I=I+1
  96. ii=NUM(I,J)
  97. c write(ioimp,*) 'on teste ',ii,' =element NUM(',I,J,')'
  98. IF(ii.eq.0) GOTO 71
  99. c on a trouvé nono !
  100. IF(ii.eq.nono) THEN
  101. c write(ioimp,*) 'on a trouvé ',ii,' element NUM(',I,J,')'
  102. IVU(inode)=I
  103. if(inode.eq.NBNODE) goto 700
  104. c si on n a pas fini on continue dans cet element
  105. inode = inode +1
  106. nono = NODE(inode)
  107. goto 72
  108. ENDIF
  109. c si on a fini de boucler sur les noeuds => element suivant
  110. if(I.eq.NBNN) goto 71
  111. goto 73
  112.  
  113. 71 CONTINUE
  114.  
  115.  
  116. C--------------------------------------------------------------
  117. c si élément non trouvé on le crée à la IEL ieme place
  118. if(NBEL.lt.IEL) then
  119. NBELEM=IEL
  120. C ici MELEME est un maillage simple (NSOUS = 0)
  121. NBSOUS = LISOUS(/1)
  122. NBREF = LISREF(/1)
  123. segadj,MELEME
  124. endif
  125. if(NUM(1,IEL).ne.0) then
  126. write(ioimp,*) 'ajouel : on écrase un élément existant !'
  127. endif
  128. do inode=1,NBNODE
  129. NUM(inode,IEL)=NODE(inode)
  130. enddo
  131. SEGSUP,IVU
  132. RETURN
  133.  
  134. C--------------------------------------------------------------
  135. c on a trouvé l element deja existant
  136. 700 CONTINUE
  137. IEL = J
  138. c write(ioimp,*) 'on a trouvé l element deja existant ',IEL
  139.  
  140.  
  141. 100 CONTINUE
  142. c==== fin de boucle sur les differents type d elements ====
  143.  
  144. SEGSUP,IVU
  145. RETURN
  146.  
  147. END
  148.  
  149.  
  150.  
  151.  

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