1 : C HATSTR SOURCE CHAT 05/01/13 00:23:20 5004 2 : SUBROUTINE HATSTR (ICOLAC) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C----------------------------------------------------------------------- 6 : C 7 : C BUT :VA A LA PECHE DES CHAPEAUX DES OBJETS SOSTU 8 : C DEJA CONTENUS DANS LES PILES 9 : C LOGIQUE: 10 : C ON SE POINTE SUR LA PILE 9 DES STRUCT 11 : C ON CREE LA TABLE DES OBJETS DU TYPE DE CETTE PILE 12 : C ON TESTE SI LE POINTEUR DE L OBJET EST DANS LA PILE 13 : C SI OUI, ON PASSE A L OBJET SUIVANT. 14 : C SI NON 15 : C SI L ENSEMBLE DES POINTEURS SOSTU EST CONTENU DANS LA PILE 12 16 : C ALORS ON RAJOUTE L OBJET DANS LA PILE 9, CE QUI OBLIGE A UN 17 : C RAPPEL DE FILLPI 18 : C 19 : C PROGRAMME PAR : FARVACQUE-REPRIS PAR LENA 20 : C APPELE PAR : SAUV 21 : C APPELLE : SORT7 SORT8 ERREUR REPERT 22 : C 23 : C======================================================================= 24 : C TABLEAU KCOLA : 25 : C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6 MCLSTR 26 : C 7 MELSTR 8 MSOLUT 9 MSTRUC 10 MTABLE 11 MAFFEC 12 MSOSTU 27 : C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL 28 : C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 29 : C======================================================================= 30 : C 31 : -INC SMSTRUC 32 : -INC CCOPTIO 33 : -INC TMCOLAC 34 : SEGMENT ILISBB 35 : INTEGER ILISOB(MLON) 36 : ENDSEGMENT 37 : DIMENSION IBID(1) 38 : C 39 : CHARACTER*(8) ITYPE 40 : C 41 : SEGACT ICOLAC 42 : ILISSE=ILISSG 43 : SEGACT ILISSE*MOD 44 : C 45 : C 46 : C **************************** MSTRUC ET MSOSTU********************* 47 : C-----ON SE POINTE SUR LA PILE DES SOSTU 48 : ITLAC1=KCOLA(12) 49 : IMAX1=ITLAC1.ITLAC(/1) 50 : IF(IMAX1.EQ.0) GO TO 598 51 : C 52 : C LA PILE DES SOSTU N EST PAS VIDE------------------------------- 53 : ITYPE='STRUCTUR' 54 : IFILE=0 54 : CALL TYPFIL (ITYPE,IFILE) 55 : IF (IFILE.LE.0) GO TO 598 56 : ITLACC=KCOLA(IFILE) 56 : CALL LISTOB(ITYPE,MLON,IBID,0) 57 : SEGINI ILISBB 57 : CALL LISTOB(ITYPE,N,ILISOB,1) 57 : C CALL REPERT (ITYPE,N) 58 : IF (N.EQ.0) GO TO 599 59 : C 60 : DO 1500 I =1,N 61 : MSTRU=ILISOB(I) 61 : C CALL LIROBJ(ITYPE,MSTRU,1,IRETOU) 62 : IF(IERR.EQ.0) RETURN 62 : CALL SNOM2(MSTRUC,ITLACC,IRET) 63 : IF(IRET.NE.0) GOTO 1500 64 : SEGACT MSTRUC 65 : NSOU=LISTRU(/1) 65 : CALL SORT8(LISTRU,NSOU,ITLAC1.ITLAC,IMAX1,IRET) 66 : SEGDES MSTRUC 67 : IF(IRET.EQ.1) GOTO 1500 67 : CALL AJOUN (ITLACC,MSTRUC,ILISSE,1) 68 : 1500 CONTINUE 69 : 599 CONTINUE 70 : SEGSUP ILISBB 71 : 600 CONTINUE 72 : 598 CONTINUE 73 : 601 CONTINUE 74 : * SEGDES ICOLAC,ILISSE 75 : RETURN 76 : END 77 : 78 : 79 : 80 : 81 : 82 :
© Cast3M 2003 - All rights reserved.
Disclaimer