1 : C RESCHA SOURCE PV 09/03/12 21:32:51 6325 2 : SUBROUTINE RESCHA (ICOLAC,ITLACC,IMAX1,IDEB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * * 7 : * Restauration des pointeurs issus de la pile des CHAMELEMs. * 8 : * * 9 : *--------------------------------------------------------------------* 10 : -INC CCOPTIO 11 : -INC SMCHAML 12 : -INC TMCOLAC 13 : CHARACTER*8 MOTIP 14 : CHARACTER*16 NOCOMP 15 : * 16 : * Boucle sur les CHAMELEMs contenus dans la pile: 17 : * 18 : ITLAC1 = KCOLA(1) 19 : DO 10 IEL =IDEB,IMAX1 20 : MCHELM = ITLAC(IEL) 21 : IF (MCHELM.EQ.0) GOTO 10 22 : SEGACT,MCHELM*MOD 23 : NSOUEL = ICHAML(/1) 24 : N3 = INFCHE(/2) 25 : IF (NSOUEL.EQ.0) GOTO 10 26 : DO 20 ISOU=1,NSOUEL 27 : MCHAML=ICHAML(ISOU) 28 : IF (MCHAML.EQ.0) GO TO 20 29 : SEGACT,MCHAML*MOD 30 : * 31 : IVA = ABS(IMACHE(ISOU)) 32 : * IF(IVA.NE.0) IMACHE(ISOU) = ITLAC1.ITLAC(IVA) 33 : * CORRECTION MILL 3 / 9 / 92 34 : IF(IVA.NE.0) IMACHE(ISOU) = ITLAC1.ITLAC(IVA) 35 : * IF(IMACHE(ISOU).LT.0) 36 : * $ IMACHE(ISOU) = ITLAC1.ITLAC(IVA) 37 : * 38 : IF(N3.GE.4) THEN 39 : ITLAC2 = KCOLA(40) 40 : IVA = ABS(INFCHE(ISOU,4)) 41 : * IF(IVA.NE.0) INFCHE(ISOU,4) = ITLAC2.ITLAC(IVA) 42 : IF(INFCHE(ISOU,4).LT.0) 43 : $ INFCHE(ISOU,4) = ITLAC2.ITLAC(IVA) 44 : ENDIF 45 : * 46 : NCO = TYPCHE(/2) 47 : DO 30 ICO=1,NCO 48 : NOCOMP = TYPCHE(ICO) 49 : IF (NOCOMP(1:6).NE.'REAL*8') THEN 50 : MOTIP(1:8)=NOCOMP(9:16) 50 : CALL TYPFIL(MOTIP,ITYP) 51 : IF(ITYP.LE.0) GO TO 30 52 : ITLAC2 = KCOLA(ITYP) 53 : MELVAL = IELVAL(ICO) 54 : IF (MELVAL.NE.0) THEN 55 : SEGACT,MELVAL*MOD 56 : N1 = IELCHE(/1) 57 : N2 = IELCHE(/2) 58 : DO 40 I2=1,N2 59 : DO 50 I1=1,N1 60 : IVA = ABS(IELCHE(I1,I2)) 61 : * IF(IVA.NE.0) IELCHE(I1,I2) = ITLAC2.ITLAC(IVA) 62 : IF(IELCHE(I1,I2).LT.0) 63 : $ IELCHE(I1,I2) = ITLAC2.ITLAC(IVA) 64 : 50 CONTINUE 65 : 40 CONTINUE 66 : SEGDES,MELVAL 67 : ENDIF 68 : ENDIF 69 : 30 CONTINUE 70 : SEGDES,MCHAML 71 : 20 CONTINUE 72 : 10 CONTINUE 73 : RETURN 74 : END 75 : 76 : 77 : 78 : 79 : 80 : 81 : 82 :
© Cast3M 2003 - All rights reserved.
Disclaimer