Télécharger la plaquette Cast3M


fr en

Télécharger kalno0.eso

Retour à la liste

Numérotation des lignes : 

kalno0

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

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