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