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    CB215821  26/08/24    21:16:59     12622          
  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 1012 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.  1012 CONTINUE
  86.       SEGDES IPT1
  87.  11   CONTINUE
  88.       SEGDES MELEME
  89. C
  90. C     Tout baigne, on peut proc‚der … l'allocation de m‚moire
  91. C     et ranger IZNOEL dans la base.
  92. C
  93.       NELVM=NELVM+1
  94. C     write(6,*)' NELVM=',nelvm,' NPT=',NPT
  95.       NBSOUS=0
  96.       NBREF=0
  97.       NBNN=NELVM
  98.       NBELEM=NPT
  99.       JG=NPT
  100.       SEGINI IZK,MLENTI
  101.       IZK.ITYPEL=28
  102.       DO 20 N=1,NPT
  103.       NELV=ITAB(1,N)
  104. C     write(6,*)'ITAB (N) =',N
  105. C     write(6,1001)(ITAB(I,N),I=1,NELV)
  106.       DO 21 I=1,NELV
  107.       IZK.NUM(I,N)=ITAB(I+1,N)
  108.       LECT(N)=ITAB(1,N)
  109.  21   CONTINUE
  110.       IF(NELV.LT.NBNN)THEN
  111.       NELVP=NELV+1
  112.       DO 22 I=NELVP,NBNN
  113.       IZK.NUM(I,N)=ITAB(NELV+1,N)
  114.  22   CONTINUE
  115.       ENDIF
  116.  20   CONTINUE
  117.       SEGDES IZK,MLENTI
  118. C
  119.       SEGSUP IZTRAV
  120.       RETURN
  121. C
  122.  98   CONTINUE
  123. C
  124. C     Le paramŠtre NEVMAX ‚tait trop faible, on va l'augmenter
  125. C     et refaire le calcul. Si on d‚passe 40 alors stop.
  126. C
  127.       SEGSUP IZTRAV
  128.       SEGDES IPT1,MELEME
  129.       NEVMAX=NEVMAX+IDIM
  130.       IF(NEVMAX.GT.40)THEN
  131.       WRITE(6,*)' NOMBRE DE CONNECTIVITES NOEUD/ELEMENT > 40 PROBLEME ?'
  132.       IRET=0
  133.       RETURN
  134.       ENDIF
  135.       GO TO 30
  136.  
  137.  1001 FORMAT(20(1X,I5))
  138.  1011 FORMAT(1X,I5,5X,15(1X,I5))
  139.       END
  140.  
  141.  
  142.  
  143.  

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