C KALNO0    SOURCE    PV        20/03/30    21:20:19     10567          
      SUBROUTINE KALNO0(MELEME,IZK,MLENTI,IZIPAD,IRET)
C**********************************************************************
C
C  Recherche des connectivits noeud/lment sur le MELEME courant.
C  Le nombre maxi d'lments auquel peut appartenir un noeud est calcul
C  au vol. Toutefois si celui-ci dpasse 40 on suspend l'excution.
C
C**********************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLENTI
      POINTEUR IZIPAD.MLENTI
-INC SMELEME
      POINTEUR MP1.MELEME,IZK.MELEME

      CHARACTER*8 TYPE

      SEGMENT/IZTRAV/(ITAB(NELV1,NPT))
C***
      IRET=1
      CALL ECRCHA('POI1')
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL PRCHAN
      CALL LIROBJ('MAILLAGE',MP1,1,IRET)
      IF(IRET.EQ.0)RETURN
      SEGACT MP1
      NPT=MP1.NUM(/2)
      JG=nbpts
      SEGINI IZIPAD
C     write(6,*)' On vient de creer un SIZIPAD , NPT=',NPT
      MLENTI=IZIPAD
      DO 1 I=1,NPT
      I1=MP1.NUM(1,I)
      LECT(I1)=I
 1    CONTINUE
C     write(6,*)' IPADL :'
C     write(6,*)(IZIPAD.LECT(I),I=1,JG)
      SEGDES MP1
      SEGACT MELEME
C     write(6,*)' IDIM=',IDIM
      IF(IDIM.EQ.2)NEVMAX=7
      IF(IDIM.EQ.3)NEVMAX=13
 30   CONTINUE
      NELV1=NEVMAX
      NELV11=NEVMAX-1
C
      NELVM=0
      SEGACT MELEME
      SEGINI IZTRAV
      NBSOUS=LISOUS(/1)
C     write(6,*)' NBSOUS=',NBSOUS
      IF(NBSOUS.EQ.0)NBSOUS=1

      MLENTI=IZIPAD
      KK=0
      IF(NBSOUS.EQ.0)NBSOUS=1
      DO 11 NS=1,NBSOUS
      IF(NBSOUS.EQ.1)IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(NS)
      SEGACT IPT1
      NP=IPT1.NUM(/1)
      NEL=IPT1.NUM(/2)
C     write(6,*)' Sous Maillage ',NS
C     write(6,1001)((ipt1.num(ii,jj),ii=1,np),jj=1,nel)


      DO 10 K=1,NEL
      KK=KK+1
      DO 10 I=1,NP
      NU=IPT1.NUM(I,K)
      NU=LECT(NU)
      NELV=ITAB(1,NU)+1
      IF(NELV.GT.NELVM)NELVM=NELV
      IF(NELV.GT.NELV11)GO TO 98
      ITAB(1,NU)=NELV
      ITAB(NELV+1,NU)=KK
 10   CONTINUE
      SEGDES IPT1
 11   CONTINUE
      SEGDES MELEME
C
C     Tout baigne, on peut procder  l'allocation de mmoire
C     et ranger IZNOEL dans la base.
C
      NELVM=NELVM+1
C     write(6,*)' NELVM=',nelvm,' NPT=',NPT
      NBSOUS=0
      NBREF=0
      NBNN=NELVM
      NBELEM=NPT
      JG=NPT
      SEGINI IZK,MLENTI
      IZK.ITYPEL=28
      DO 20 N=1,NPT
      NELV=ITAB(1,N)
C     write(6,*)'ITAB (N) =',N
C     write(6,1001)(ITAB(I,N),I=1,NELV)
      DO 21 I=1,NELV
      IZK.NUM(I,N)=ITAB(I+1,N)
      LECT(N)=ITAB(1,N)
 21   CONTINUE
      IF(NELV.LT.NBNN)THEN
      NELVP=NELV+1
      DO 22 I=NELVP,NBNN
      IZK.NUM(I,N)=ITAB(NELV+1,N)
 22   CONTINUE
      ENDIF
 20   CONTINUE
      SEGDES IZK,MLENTI
C
      SEGSUP IZTRAV
      RETURN
C
 98   CONTINUE
C
C     Le paramtre NEVMAX tait trop faible, on va l'augmenter
C     et refaire le calcul. Si on dpasse 40 alors stop.
C
      SEGSUP IZTRAV
      SEGDES IPT1,MELEME
      NEVMAX=NEVMAX+IDIM
      IF(NEVMAX.GT.40)THEN
      WRITE(6,*)' NOMBRE DE CONNECTIVITES NOEUD/ELEMENT > 40 PROBLEME ?'
      IRET=0
      RETURN
      ENDIF
      GO TO 30

 1001 FORMAT(20(1X,I5))
 1011 FORMAT(1X,I5,5X,15(1X,I5))
      END