1 : C FILLP1 SOURCE CHAT 05/01/13 00:00:17 5004 2 : SUBROUTINE FILLP1 (ICOLAC,IMAX) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C 7 : C ON COMPLETE LA PILE DE MELEME 8 : C IMAX : NUMERO MAX DE POINT 9 : C 10 : C ECRIT PAR FARVACQUE -REPRIS PAR LENA 11 : C APPELE PAR SAUVV 12 : C APPELLE : AJOUN SNOM2 REPERT 13 : C======================================================================= 14 : -INC CCOPTIO 15 : -INC SMELEME 16 : -INC TMCOLAC 17 : SEGMENT ILISBB 18 : INTEGER ILISOB(MLON) 19 : ENDSEGMENT 20 : CHARACTER*8 CTYP 21 : DIMENSION ILENA(10) 22 : DATA CTYP/'MAILLAGE'/ 23 : C 24 : C 25 : C **** ON PREND TOUS LES MELEME DONT TOUS LES NOEUDS SONT INFERIEURS 26 : C **** A IMAX . IL Y EN A IMAX2 27 : C 28 : SEGACT ICOLAC 29 : ILISSE=ILISSG 30 : SEGACT ILISSE*MOD 30 : CALL LISTOB(CTYP,MLON,ILENA,0) 31 : SEGINI ILISBB 31 : CALL LISTOB(CTYP,N,ILISOB,1) 31 : C CALL REPERT (CTYP ,N) 32 : IF (N.EQ.0) GO TO 100 33 : ICO=KCOLA(1) 34 : ITLACC =KCOLA (1) 35 : DO 200 M=1,N 36 : MELEME=ILISOB(M) 36 : C CALL LIROBJ(CTYP,MELEME,1,IRETOU) 37 : IF(IERR.NE.0) RETURN 37 : CALL SNOM2 (MELEME,ITLACC,IRET) 38 : IF (IRET.GT.0) GOTO 200 39 : C --- LE MELEME N EST PAS DANS LA PILE 40 : C --- ON REGARDE SI SES NUMEROS SONT .LE.IMAX 41 : SEGACT MELEME 42 : C 43 : IPT1=MELEME 44 : NTOTO=LISOUS(/1) 45 : KRET=0 46 : IF(NTOTO.NE.0) GOTO 53 46 : CALL TESTNU (MELEME,IMAX,IRET) 47 : KRET=IRET 48 : GO TO 54 49 : 53 CONTINUE 50 : DO 52 JJ=1,NTOTO 51 : MELEME=IPT1.LISOUS(JJ) 51 : CALL TESTNU (MELEME,IMAX,IRET) 52 : KRET=KRET+IRET 53 : 52 CONTINUE 54 : 54 MELEME=IPT1 55 : IF(KRET.NE.0) GOTO 51 56 : C --- CE MELEME A SES NUM INFERIEURS OU EGAL A IMAX 57 : C --- ON LE RAJOUTE DANS LA PILE 1 58 : C --- AINSI QUE SES LISOUS ET LISREF 59 : IVA=IPT1 59 : CALL AJOUN (ITLACC,IVA,ILISSE,1) 60 : C 61 : SEGACT MELEME 62 : IF(LISOUS(/1).EQ.0) GO TO 58 63 : DO 59 I=1,LISOUS(/1) 64 : IVA=LISOUS(I) 64 : CALL AJOUN(ITLACC,IVA,ILISSE,1) 65 : C LISOUS(I)=IVA 66 : 59 CONTINUE 67 : 58 IF(LISREF(/1).EQ.0) GOTO 64 68 : DO 61 I=1,LISREF(/1) 69 : IVA=LISREF(I) 69 : CALL AJOUN(ITLACC,IVA,ILISSE,1) 70 : C LISREF(I)=IVA 71 : 61 CONTINUE 72 : 64 SEGDES MELEME 73 : 51 CONTINUE 74 : C-----------------ATTENTION Y A T IL PLUSIEURS NIVEAUX DE LISTREF 75 : C-----------------SI OUI OBLIGATION DE REFAIRE UN PASSAGE DANS FILLPI 76 : 200 CONTINUE 77 : C 78 : 100 CONTINUE 79 : SEGSUP ILISBB 80 : * SEGDES ILISSE 81 : SEGDES ICOLAC 82 : RETURN 83 : END 84 : 85 : 86 : 87 : 88 : 89 :
© Cast3M 2003 - All rights reserved.
Disclaimer