Télécharger extipd.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTIPD SOURCE PV 16/11/17 21:59:24 9180
  2. SUBROUTINE EXTIPD
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : EXTIPD
  7. C DESCRIPTION : Extrait les noms d'inconnues primales ou duales
  8. C d'un MATRIK, on réduit à CH*4 pour des raisons
  9. C de compatibilité
  10. C
  11. C
  12. C LANGAGE : ESOPE
  13. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  14. C mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES :
  17. C APPELES (E/S) :
  18. C APPELES (BLAS) :
  19. C APPELES (CALCUL) :
  20. C APPELE PAR :
  21. C***********************************************************************
  22. C SYNTAXE GIBIANE :
  23. C LMOT1 = 'KOPS' 'EXTRINPR' MATRIK1 ;
  24. C LMOT1 = 'KOPS' 'EXTRINDU' MATRIK1 ;
  25. C ENTREES :
  26. C ENTREES/SORTIES :
  27. C SORTIES :
  28. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  29. C***********************************************************************
  30. C VERSION : v1, 10/05/2006, version initiale
  31. C HISTORIQUE : v1, 10/05/2006, création
  32. C HISTORIQUE :
  33. C HISTORIQUE :
  34. C***********************************************************************
  35. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  36. C en cas de modification de ce sous-programme afin de faciliter
  37. C la maintenance !
  38. C***********************************************************************
  39. -INC CCOPTIO
  40. -INC SMLMOTS
  41. POINTEUR LINC.MLMOTS
  42. POINTEUR LINC2.MLMOTS
  43. *
  44. INTEGER IMPR,IRET
  45. *
  46. * Executable statements
  47. *
  48. IMPR=0
  49. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extipd.eso'
  50. CALL LIROBJ('MATRIK ',MATRIK,1,IRETOU)
  51. IF (IERR.NE.0) RETURN
  52. * D'abord les primales puis les duales
  53. * On renverse l'ordre car ecrobj écrit sur une pile
  54. DO IPRIDU=2,1,-1
  55. *
  56. * Dim max de LINC
  57. *
  58. JGM=0
  59. SEGACT MATRIK
  60. NMAT=IRIGEL(/2)
  61. DO IMAT=1,NMAT
  62. IMATRI=IRIGEL(4,IMAT)
  63. SEGACT IMATRI
  64. JGM=JGM+LIZAFM(/2)
  65. ENDDO
  66. *
  67. * Remplissage de LINC
  68. *
  69. JGN=4
  70. IGM=0
  71. SEGINI LINC
  72. DO IMAT=1,NMAT
  73. IMATRI=IRIGEL(4,IMAT)
  74. NBME=LIZAFM(/2)
  75. DO IBME=1,NBME
  76. IGM=IGM+1
  77. IF (IPRIDU.EQ.1) THEN
  78. LINC.MOTS(IGM)=LISPRI(IBME)
  79. ELSEIF (IPRIDU.EQ.2) THEN
  80. LINC.MOTS(IGM)=LISDUA(IBME)
  81. ELSE
  82. GOTO 9999
  83. ENDIF
  84. ENDDO
  85. SEGDES IMATRI
  86. ENDDO
  87. SEGDES MATRIK
  88. *
  89. * Enlever les doublons dans LINC
  90. *
  91. SEGINI,LINC2=LINC
  92. CALL CUNIQ(LINC2.MOTS,LINC2.MOTS(/1),LINC2.MOTS(/2),
  93. $ LINC.MOTS,NIUNIQ,
  94. $ IMPR,IRET)
  95. IF (IRET.NE.0) GOTO 9999
  96. JGN=4
  97. JGM=NIUNIQ
  98. SEGADJ,LINC
  99. SEGSUP LINC2
  100. SEGDES LINC
  101. CALL ECROBJ('LISTMOTS',LINC)
  102. ENDDO
  103. *
  104. * Normal termination
  105. *
  106. * IRET=0
  107. RETURN
  108. *
  109. * Format handling
  110. *
  111. *
  112. * Error handling
  113. *
  114. 9999 CONTINUE
  115. * IRET=1
  116. WRITE(IOIMP,*) 'An error was detected in subroutine extipd'
  117. CALL ERREUR(5)
  118. RETURN
  119. *
  120. * End of subroutine EXTIPD
  121. *
  122. END
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  

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