Numérotation des lignes :

C KALNO0    SOURCE    CHAT      05/01/13    00:50:43     5004      SUBROUTINE KALNO0(MELEME,IZK,MLENTI,IZIPAD,IRET)C**********************************************************************CC  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.CC**********************************************************************      IMPLICIT INTEGER(I-N)      IMPLICIT REAL*8 (A-H,O-Z) -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=XCOOR(/1)/(IDIM+1)      SEGINI IZIPADC     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    CONTINUEC     write(6,*)' IPADL :'C     write(6,*)(IZIPAD.LECT(I),I=1,JG)      SEGDES MP1      SEGACT MELEMEC     write(6,*)' IDIM=',IDIM      IF(IDIM.EQ.2)NEVMAX=7      IF(IDIM.EQ.3)NEVMAX=13 30   CONTINUE      NELV1=NEVMAX      NELV11=NEVMAX-1C      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 ',NSC     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 MELEMECC     Tout baigne, on peut proc‚der … l'allocation de m‚moireC     et ranger IZNOEL dans la base.C      NELVM=NELVM+1C     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) =',NC     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,MLENTIC      SEGSUP IZTRAV      RETURNC 98   CONTINUECC     Le paramŠtre NEVMAX ‚tait trop faible, on va l'augmenterC     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

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