1 : C HATRIG SOURCE CHAT 09/10/09 21:18:43 6519 2 : SUBROUTINE HATRIG (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 RIGIDITES 8 : C DEJA CONTENUS DANS LES PILES 9 : C LOGIQUE: 10 : C ON SE POINTE SUR LA PILE 11 : C ON CREE LA TABLE DES OBJETS DU TYPE DE CETTE PILE 12 : C-- CAS GENERAL 13 : C ON TESTE SI LE POINTEUR DANS L OBJET EST DANS LA PILE 14 : C SI OUI, ON PASSE A L OBJET SUIVANT. 15 : C SI NON 16 : C 17 : C 18 : C SI L ENSEMBLE DES POINTEURS EST CONTENU DANS LE ITLAC ASSOCIE 19 : C ALORS ON RAJOUTE L OBJET DANS LA PILE , CE QUI OBLIGE A UN 20 : C RAPPEL DE FILLPI 21 : C 22 : C PROGRAMME PAR : FARVACQUE-REPRIS PAR LENA 23 : C APPELE PAR : SAUV 24 : C APPELLE : SORT7 SORT8 ERREUR REPERT 25 : C 26 : C======================================================================= 27 : C TABLEAU KCOLA : 28 : C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6 MCLSTR 29 : C 7 MELSTR 8 MSOLUT 9 MSTRUC 10 11 MAFFEC 12 MSOSTU 30 : C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL 31 : C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 32 : C======================================================================= 33 : C 34 : -INC SMRIGID 35 : -INC CCOPTIO 36 : -INC TMCOLAC 37 : SEGMENT ILISBB 38 : INTEGER ILISOB(MLON) 39 : ENDSEGMENT 40 : DIMENSION IBID(1) 41 : C 42 : CHARACTER*(8) ITYPE 43 : C 44 : SEGACT ICOLAC 45 : ILISSE=ILISSG 46 : SEGACT ILISSE*MOD 47 : C 48 : C 49 : C **************************** MRIGID ****************************** 50 : C 51 : IFILE=0 52 : ITYPE='RIGIDITE' 52 : CALL TYPFIL (ITYPE,IFILE) 53 : ITLACC=KCOLA(IFILE) 54 : IMAX1=ITLAC(/1) 55 : IF(IMAX1.EQ.0) GO TO 600 55 : CALL LISTOB(ITYPE,MLON,IBID,0) 56 : SEGINI ILISBB 56 : CALL LISTOB(ITYPE,N,ILISOB,1) 57 : C LA PILE N EST PAS VIDE------------------------------- 57 : C CALL REPERT (ITYPE,N) 58 : IF (N.EQ.0) GO TO 599 59 : ITLAC1=KCOLA(1) 60 : ITLAC2=KCOLA(11) 61 : ITLAC3=KCOLA(13) 62 : C 63 : DO 1500 I =1,N 64 : MRIGID = ILISOB(I) 64 : C CALL LIROBJ(ITYPE,MRIGID,1,IRETOU) 64 : CALL SNOM2(MRIGID,ITLACC,IRET) 65 : IF(IRET.NE.0) GOTO 1500 66 : C --- ON RECHERCHE PLUS PROFONDEMENT 67 : SEGACT MRIGID 68 : NRIGEL=IRIGEL(/2) 69 : DO 1501 IR=1,NRIGEL 70 : DO 1502 J=1,IMAX1 71 : RI1=ITLAC(J) 72 : if(ri1.eq.0) goto 1502 73 : SEGACT RI1 74 : NRIGE1=RI1.IRIGEL(/2) 75 : DO 1503 K=1,NRIGE1 76 : C KK=ITLAC1.ITLAC(RI1.IRIGEL(1,K)) 77 : C IF(IRIGEL(1,IR).NE.KK) GOTO 1503 78 : C IF(RI1.IRIGEL(2,K).EQ.0) THEN 79 : C KK=0 80 : C ELSE 81 : C KK=ITLAC2.ITLAC(RI1.IRIGEL(2,K)) 82 : C ENDIF 83 : C IF(IRIGEL(2,IR).NE.KK) GOTO 1503 84 : C KK=ITLAC3.ITLAC(RI1.IRIGEL(4,K)) 85 : C IF(IRIGEL(4,IR).NE.KK) GOTO 1503 86 : IF(IRIGEL(4,IR).NE.RI1.IRIGEL(4,K)) GOTO 1503 87 : SEGDES RI1 88 : GOTO 1501 89 : 1503 CONTINUE 90 : SEGDES RI1 91 : 1502 CONTINUE 92 : SEGDES MRIGID 93 : GOTO 1500 94 : 1501 CONTINUE 95 : SEGDES MRIGID 95 : CALL AJOUN (ITLACC,MRIGID,ILISSE,1) 96 : 1500 CONTINUE 97 : 599 CONTINUE 98 : SEGSUP ILISBB 99 : 600 CONTINUE 100 : * SEGDES ICOLAC,ILISSE 101 : RETURN 102 : END 103 : 104 : 105 : 106 : 107 : 108 : 109 : 110 : 111 : 112 : 113 : 114 :
© Cast3M 2003 - All rights reserved.
Disclaimer