Télécharger kalno0.eso

Retour à la liste

Numérotation des lignes :

  1. C KALNO0 SOURCE CHAT 05/01/13 00:50:43 5004
  2. SUBROUTINE KALNO0(MELEME,IZK,MLENTI,IZIPAD,IRET)
  3. C**********************************************************************
  4. C
  5. C Recherche des connectivit‚s noeud/‚l‚ment sur le MELEME courant.
  6. C Le nombre maxi d'‚l‚ments auquel peut appartenir un noeud est calcul‚
  7. C au vol. Toutefois si celui-ci d‚passe 40 on suspend l'ex‚cution.
  8. C
  9. C**********************************************************************
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8 (A-H,O-Z)
  12.  
  13. -INC CCOPTIO
  14. -INC SMCOORD
  15. -INC SMLENTI
  16. POINTEUR IZIPAD.MLENTI
  17. -INC SMELEME
  18. POINTEUR MP1.MELEME,IZK.MELEME
  19.  
  20. CHARACTER*8 TYPE
  21.  
  22. SEGMENT/IZTRAV/(ITAB(NELV1,NPT))
  23. C***
  24. IRET=1
  25. CALL ECRCHA('POI1')
  26. CALL ECROBJ('MAILLAGE',MELEME)
  27. CALL PRCHAN
  28. CALL LIROBJ('MAILLAGE',MP1,1,IRET)
  29. IF(IRET.EQ.0)RETURN
  30. SEGACT MP1
  31. NPT=MP1.NUM(/2)
  32. JG=XCOOR(/1)/(IDIM+1)
  33. SEGINI IZIPAD
  34. C write(6,*)' On vient de creer un SIZIPAD , NPT=',NPT
  35. MLENTI=IZIPAD
  36. DO 1 I=1,NPT
  37. I1=MP1.NUM(1,I)
  38. LECT(I1)=I
  39. 1 CONTINUE
  40. C write(6,*)' IPADL :'
  41. C write(6,*)(IZIPAD.LECT(I),I=1,JG)
  42. SEGDES MP1
  43. SEGACT MELEME
  44. C write(6,*)' IDIM=',IDIM
  45. IF(IDIM.EQ.2)NEVMAX=7
  46. IF(IDIM.EQ.3)NEVMAX=13
  47. 30 CONTINUE
  48. NELV1=NEVMAX
  49. NELV11=NEVMAX-1
  50. C
  51. NELVM=0
  52. SEGACT MELEME
  53. SEGINI IZTRAV
  54. NBSOUS=LISOUS(/1)
  55. C write(6,*)' NBSOUS=',NBSOUS
  56. IF(NBSOUS.EQ.0)NBSOUS=1
  57.  
  58. MLENTI=IZIPAD
  59. KK=0
  60. IF(NBSOUS.EQ.0)NBSOUS=1
  61. DO 11 NS=1,NBSOUS
  62. IF(NBSOUS.EQ.1)IPT1=MELEME
  63. IF(NBSOUS.NE.1)IPT1=LISOUS(NS)
  64. SEGACT IPT1
  65. NP=IPT1.NUM(/1)
  66. NEL=IPT1.NUM(/2)
  67. C write(6,*)' Sous Maillage ',NS
  68. C write(6,1001)((ipt1.num(ii,jj),ii=1,np),jj=1,nel)
  69.  
  70.  
  71.  
  72. DO 10 K=1,NEL
  73. KK=KK+1
  74. DO 10 I=1,NP
  75. NU=IPT1.NUM(I,K)
  76. NU=LECT(NU)
  77. NELV=ITAB(1,NU)+1
  78. IF(NELV.GT.NELVM)NELVM=NELV
  79. IF(NELV.GT.NELV11)GO TO 98
  80. ITAB(1,NU)=NELV
  81. ITAB(NELV+1,NU)=KK
  82. 10 CONTINUE
  83. SEGDES IPT1
  84. 11 CONTINUE
  85. SEGDES MELEME
  86. C
  87. C Tout baigne, on peut proc‚der … l'allocation de m‚moire
  88. C et ranger IZNOEL dans la base.
  89. C
  90. NELVM=NELVM+1
  91. C write(6,*)' NELVM=',nelvm,' NPT=',NPT
  92. NBSOUS=0
  93. NBREF=0
  94. NBNN=NELVM
  95. NBELEM=NPT
  96. JG=NPT
  97. SEGINI IZK,MLENTI
  98. IZK.ITYPEL=28
  99. DO 20 N=1,NPT
  100. NELV=ITAB(1,N)
  101. C write(6,*)'ITAB (N) =',N
  102. C write(6,1001)(ITAB(I,N),I=1,NELV)
  103. DO 21 I=1,NELV
  104. IZK.NUM(I,N)=ITAB(I+1,N)
  105. LECT(N)=ITAB(1,N)
  106. 21 CONTINUE
  107. IF(NELV.LT.NBNN)THEN
  108. NELVP=NELV+1
  109. DO 22 I=NELVP,NBNN
  110. IZK.NUM(I,N)=ITAB(NELV+1,N)
  111. 22 CONTINUE
  112. ENDIF
  113. 20 CONTINUE
  114. SEGDES IZK,MLENTI
  115. C
  116. SEGSUP IZTRAV
  117. RETURN
  118. C
  119. 98 CONTINUE
  120. C
  121. C Le paramŠtre NEVMAX ‚tait trop faible, on va l'augmenter
  122. C et refaire le calcul. Si on d‚passe 40 alors stop.
  123. C
  124. SEGSUP IZTRAV
  125. SEGDES IPT1,MELEME
  126. NEVMAX=NEVMAX+IDIM
  127. IF(NEVMAX.GT.40)THEN
  128. WRITE(6,*)' NOMBRE DE CONNECTIVITES NOEUD/ELEMENT > 40 PROBLEME ?'
  129. IRET=0
  130. RETURN
  131. ENDIF
  132. GO TO 30
  133.  
  134. 1001 FORMAT(20(1X,I5))
  135. 1011 FORMAT(1X,I5,5X,15(1X,I5))
  136. END
  137.  
  138.  

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