1 : C EXARIG SOURCE CHAT 09/10/13 21:15:00 6528 2 : SUBROUTINE EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA) 3 : C---------------------------------------------------------------------- 4 : C 5 : C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE 6 : C SI IIICHA =1 ON CHANGE LES POINTEURS---- 7 : C 8 : C ENTREE ITLACC PILE EXAMINEE 9 : C ICOLAC POINTEURS DES PILES A REMPLIR 10 : C M1 PREMIER INDICE D EXAMEN DANS LA PILE 11 : C M2 DERNIER INDICE 12 : C IIICHA =1 ON CHANGE LES POINTEURS 13 : C---------------------------------------------------------------- 14 : C APPELE PAR EXPIL 15 : C APPELLE AJOUN 16 : C 17 : C======================================================================= 18 : C TABLEAU KCOLA : 19 : C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6 20 : C 7 8 MSOLUT 9 MSTRUC 10 MTABLE 11 MAFFEC 12 MSOSTU 21 : C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL 22 : C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 23 MSUPER 23 : C======================================================================= 24 : C 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8(A-H,O-Z) 27 : -INC SMRIGID 28 : -INC CCOPTIO 29 : -INC TMCOLAC 30 : -INC TMVECRIG 31 : C **************************** MRIGID ****************************** 32 : ICO1=KCOLA(1) 33 : * ICO2=KCOLA(11) ON REMPLACE PAR UN OBJET MELEME AM 12/2/90 34 : ICO3=KCOLA(13) 35 : ICO4=KCOLA(16) 36 : ICO5=KCOLA(10) 37 : ICO6=KCOLA(2) 38 : ico7=kcola(3) 39 : ILISSE=ILISSG 40 : SEGACT ILISSE*MOD 41 : 503 CONTINUE 42 : 43 : DO 606 IEL=M1,M2 44 : MRIGID=ITLAC(IEL) 45 : IF (MRIGID.EQ.0) GO TO 606 46 : SEGACT MRIGID*MOD 47 : NRIGEL=IRIGEL(/2) 48 : DO 607 I=1,NRIGEL 49 : 50 : C ... On rajoute le maillage sur la pile N° 1 ... 51 : IVA=IRIGEL(1,I) 52 : IF(IVA.GT.0) THEN 52 : CALL AJOUN(ICO1,IVA,ILISSE,1) 53 : IF(IIICHA.EQ.1)IRIGEL(1,I)=-IVA 54 : ENDIF 55 : 56 : C ... On rajoute le maillage frottement sur la pile N° 1 ... 57 : IVA=IRIGEL(2,I) 58 : IF(IVA.EQ.0) GOTO 612 59 : IF(IVA.GT.0) THEN 59 : CALL AJOUN(ICO1,IVA,ILISSE,1) 60 : IF(IIICHA.EQ.1)IRIGEL(2,I)=-IVA 61 : ENDIF 62 : 612 CONTINUE 63 : 64 : C ... On rajoute le IMATRI sur la pile N° 13 ... 65 : * IVA=IRIGEL(4,I) 66 : * IF(IVA.GT.0) THEN 66 : * CALL AJOUN(ICO3,IVA,ILISSE,1) 67 : * IF(IIICHA.EQ.1)IRIGEL(4,I)=-IVA 68 : * ENDIF 69 : 70 : 607 CONTINUE 71 : 72 : * NE PAS OUBLIER DE SAUVER LA TABLE SI ELLE EXISTE 73 : IF (ISUPEQ.NE.0) THEN 74 : C ... On rajoute la TABLE sur la pile N° 10 ... 75 : IVA=ISUPEQ 75 : CALL AJOUN(ICO5,IVA,ILISSE,1) 76 : IF(IIICHA.EQ.1) ISUPEQ=IVA 77 : ENDIF 78 : 79 : IF(ICHOLE.EQ.0) GOTO 613 80 : IVA=ICHOLE 81 : IF(IVA.GT.0) THEN 82 : C ... On rajoute ICHOLE sur la pile N° 16 ... 82 : CALL AJOUN(ICO4,IVA,ILISSE,1) 83 : C ... On met le pointeur négatif pour qu'on puisse reconnaître 84 : C le pointeur sur la pile du pointeur GEMAT (voir SORTRI, WRPIL 85 : C et RESTRI) ... 86 : IF(IIICHA.EQ.1) ICHOLE=-IVA 87 : ENDIF 88 : 613 CONTINUE 89 : 90 : IF(IMGEO1.EQ.0) GOTO 640 91 : IMGEOD=IMGEO1 92 : SEGACT IMGEOD*MOD 93 : DO 641 I=1,IMGEOR(/1) 94 : IVA=IMGEOR(I) 95 : IF(IVA.GT.0) THEN 95 : CALL AJOUN(ICO1,IVA,ILISSE,1) 96 : IF(IIICHA.EQ.1) IMGEOR(I)=-IVA 97 : ENDIF 98 : 641 CONTINUE 99 : SEGDES IMGEOD 100 : 640 CONTINUE 101 : IF(IVECRI.NE.0) THEN 102 : MVECRI=IVECRI 103 : SEGACT MVECRI*MOD 104 : DO 651 i=1,MELZON(/1) 105 : iva=melzon(i) 106 : IF(IVA.GT.0) THEN 106 : CALL AJOUN(ICO1,IVA,ILISSE,1) 107 : IF(IIICHA.EQ.1) MELZON(I)=-IVA 108 : ENDIF 109 : 651 CONTINUE 110 : SEGDES MVECRI 111 : ENDIF 112 : IF (IMGEO2.NE.0) THEN 113 : IVA=IMGEO2 113 : CALL AJOUN(ICO6,IVA,ILISSE,1) 114 : IF(IIICHA.EQ.1) IMGEO2=-IVA 115 : ENDIF 116 : if(jrcond.ne.0) then 117 : iva=jrcond 117 : call ajoun(ico7,iva,ilisse,1) 118 : if(iiicha.eq.1) jrcond= -iva 119 : endif 120 : if(jrdepp.ne.0) then 121 : iva=jrdepp 121 : call ajoun(ico7,iva,ilisse,1) 122 : if(iiicha.eq.1) jrdepp= -iva 123 : endif 124 : if(jrdepd.ne.0) then 125 : iva=jrdepd 125 : call ajoun(ico7,iva,ilisse,1) 126 : if(iiicha.eq.1) jrdepd= -iva 127 : endif 128 : if(jrelim.ne.0) then 129 : iva=jrelim 129 : call ajoun(ico7,iva,ilisse,1) 130 : if(iiicha.eq.1) jrelim= -iva 131 : endif 132 : if(jrgard.ne.0) then 133 : iva=jrgard 133 : call ajoun(ico7,iva,ilisse,1) 134 : if(iiicha.eq.1) jrgard= -iva 135 : endif 136 : if(jrtot.ne.0) then 137 : iva=jrtot 137 : call ajoun(ico7,iva,ilisse,1) 138 : if(iiicha.eq.1) jrtot= -iva 139 : endif 140 : if(imlag.ne.0) then 141 : * write (6,*) ' dans exarig ',imlag 142 : iva=imlag 142 : call ajoun(ico1,iva,ilisse,1) 143 : if(iiicha.eq.1) imlag= -iva 144 : endif 145 : SEGDES MRIGID 146 : 606 CONTINUE 147 : GO TO 599 148 : C********************************************************************* 149 : 599 CONTINUE 150 : * SEGDES ILISSE 151 : RETURN 152 : END 153 : 154 : 155 : 156 : 157 : 158 : 159 : 160 : 161 : 162 : 163 : 164 :
© Cast3M 2003 - All rights reserved.
Disclaimer