Télécharger resmik.eso

Retour à la liste

Numérotation des lignes :

  1. C RESMIK SOURCE PV 16/11/26 21:16:20 9205
  2. SUBROUTINE RESMIK (ICOLAC,ITLACC,IMAX1,IDEB)
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C***********************************************************************
  7. C NOM : RESMIK
  8. C DESCRIPTION : Restauration des pointeurs dans les objets
  9. C de type MATRIK.
  10. C (appelé par restpi.eso)
  11. C
  12. C LANGAGE : ESOPE
  13. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  14. C mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C SYNTAXE GIBIANE : -
  17. C ENTREES : ICOLAC, chapeau sur les piles ITLACC
  18. C (une pour chaque type d'objets)
  19. C IDEB, IMAX1, indice de début et de fin
  20. C sur la pile d'objets MATRIK
  21. C ENTREES/SORTIES : ITLACC, la pile des objets MATRIK sur
  22. C lesquels on va restaurer des pointeurs
  23. C***********************************************************************
  24. C VERSION : v1, 15/07/98, version initiale
  25. C HISTORIQUE : v1, 15/07/98, création
  26. C HISTORIQUE :
  27. C HISTORIQUE :
  28. C***********************************************************************
  29. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  30. C en cas de modification de ce sous-programme afin de faciliter
  31. C la maintenance !
  32. C***********************************************************************
  33. -INC CCOPTIO
  34. -INC TMCOLAC
  35. C
  36. C ************************* MATRIK ********************************
  37. C Pile des MELEME
  38. ITLAC1=KCOLA(1)
  39. C Pile des CHPOINT
  40. ITLAC2=KCOLA(2)
  41. C Pile des MATRIK
  42. ITLAC3=KCOLA(43)
  43. DO 1 IEL=IDEB,IMAX1
  44. MATRIK=ITLAC(IEL)
  45. IF (MATRIK.EQ.0) THEN
  46. WRITE(IOIMP,*) 'Failing to save a nil pointer'
  47. WRITE(IOIMP,*) 'MATRIK type object...'
  48. GOTO 9999
  49. ENDIF
  50. SEGACT MATRIK*MOD
  51. NMATRI=IRIGEL(/2)
  52. DO 11 I=1,NMATRI
  53. IVA=ABS(IRIGEL(1,I))
  54. IF (IVA.NE.0) IRIGEL(1,I)=ITLAC1.ITLAC(IVA)
  55. IVA=ABS(IRIGEL(2,I))
  56. IF (IVA.NE.0) IRIGEL(2,I)=ITLAC1.ITLAC(IVA)
  57. IMATRI=IRIGEL(4,I)
  58. IF (IMATRI.NE.0) THEN
  59. SEGACT IMATRI*MOD
  60. IVA=ABS(KSPGP)
  61. IF (IVA.NE.0) KSPGP=ITLAC1.ITLAC(IVA)
  62. IVA=ABS(KSPGD)
  63. IF (IVA.NE.0) KSPGD=ITLAC1.ITLAC(IVA)
  64. SEGDES IMATRI
  65. ENDIF
  66. 11 CONTINUE
  67. IVA=ABS(KIZM)
  68. IF (IVA.NE.0) KIZM=ITLAC1.ITLAC(IVA)
  69. IVA=ABS(KISPGT)
  70. IF (IVA.NE.0) KISPGT=ITLAC1.ITLAC(IVA)
  71. IVA=ABS(KISPGP)
  72. IF (IVA.NE.0) KISPGP=ITLAC1.ITLAC(IVA)
  73. IVA=ABS(KISPGD)
  74. IF (IVA.NE.0) KISPGD=ITLAC1.ITLAC(IVA)
  75. IVA=ABS(KIDMAT(8))
  76. IF (IVA.NE.0) KIDMAT(8)=ITLAC2.ITLAC(IVA)
  77. IVA=ABS(KKMMT(2))
  78. IF (IVA.NE.0) KKMMT(2)=ITLAC3.ITLAC(IVA)
  79. IVA=ABS(KKMMT(3))
  80. IF (IVA.NE.0) KKMMT(3)=ITLAC3.ITLAC(IVA)
  81. SEGDES MATRIK
  82. 1 CONTINUE
  83. *
  84. * Normal termination
  85. *
  86. RETURN
  87. *
  88. * Format handling
  89. *
  90. *
  91. * Error handling
  92. *
  93. 9999 CONTINUE
  94. WRITE(IOIMP,*) 'An error was detected in subroutine resmik'
  95. RETURN
  96. *
  97. * End of subroutine RESMIK
  98. *
  99. END
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  

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