Télécharger rescha.eso

Retour à la liste

Numérotation des lignes :

  1. C RESCHA SOURCE PV 17/10/03 21:16:26 9581
  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. ITLAC3 = KCOLA(48)
  20. DO 10 IEL =IDEB,IMAX1
  21. MCHELM = ITLAC(IEL)
  22. IF (MCHELM.EQ.0) GOTO 10
  23. SEGACT,MCHELM*MOD
  24. NSOUEL = ICHAML(/1)
  25. N3 = INFCHE(/2)
  26. IF (NSOUEL.EQ.0) GOTO 10
  27. DO 20 ISOU=1,NSOUEL
  28. MCHAML=ICHAML(ISOU)
  29. IF (MCHAML.EQ.0) GO TO 20
  30. SEGACT,MCHAML*MOD
  31. *
  32. IVA = ABS(IMACHE(ISOU))
  33. * IF(IVA.NE.0) IMACHE(ISOU) = ITLAC1.ITLAC(IVA)
  34. * CORRECTION MILL 3 / 9 / 92
  35. IF(IVA.NE.0) IMACHE(ISOU) = ITLAC1.ITLAC(IVA)
  36. * IF(IMACHE(ISOU).LT.0)
  37. * $ IMACHE(ISOU) = ITLAC1.ITLAC(IVA)
  38. *
  39. IF(N3.GE.4) THEN
  40. ITLAC2 = KCOLA(40)
  41. IVA = ABS(INFCHE(ISOU,4))
  42. * IF(IVA.NE.0) INFCHE(ISOU,4) = ITLAC2.ITLAC(IVA)
  43. IF(INFCHE(ISOU,4).LT.0)
  44. $ INFCHE(ISOU,4) = ITLAC2.ITLAC(IVA)
  45. ENDIF
  46. *
  47. NCO = TYPCHE(/2)
  48. DO 30 ICO=1,NCO
  49. NOCOMP = TYPCHE(ICO)
  50. IF (NOCOMP(1:6).NE.'REAL*8') THEN
  51. MOTIP(1:8)=NOCOMP(9:16)
  52. CALL TYPFIL(MOTIP,ITYP)
  53. IF(ITYP.LE.0) GO TO 30
  54. ITLAC2 = KCOLA(ITYP)
  55. MELVAL = IELVAL(ICO)
  56. IF (MELVAL.NE.0) THEN
  57. SEGACT,MELVAL*MOD
  58. N1 = IELCHE(/1)
  59. N2 = IELCHE(/2)
  60. DO 40 I2=1,N2
  61. DO 50 I1=1,N1
  62. IVA = ABS(IELCHE(I1,I2))
  63. * IF(IVA.NE.0) IELCHE(I1,I2) = ITLAC2.ITLAC(IVA)
  64. IF(IELCHE(I1,I2).LT.0)
  65. $ IELCHE(I1,I2) = ITLAC2.ITLAC(IVA)
  66. 50 CONTINUE
  67. 40 CONTINUE
  68. SEGDES,MELVAL
  69. ENDIF
  70. ELSE
  71. ** write (6,*) ' rescha iva ',ielval(ico)
  72. IVA=ABS(IELVAL(ICO))
  73. IF (IELVAL(ICO).LT.0) IELVAL(ICO)=ITLAC3.ITLAC(IVA)
  74. ** write (6,*) ' rescha apres ',ielval(ico)
  75. ENDIF
  76. 30 CONTINUE
  77. SEGDES,MCHAML
  78. 20 CONTINUE
  79. 10 CONTINUE
  80. RETURN
  81. END
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales