Télécharger exinck.eso

Retour à la liste

Numérotation des lignes :

  1. C EXINCK SOURCE PV 16/11/17 21:59:21 9180
  2. SUBROUTINE EXINCK(MATIN,LINCP,LINCD,MATOUT,IMPR,IRET)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : EXINCK
  7. C DESCRIPTION : Extrait d'un MATRIK la sous-matrice
  8. C d'inconnues primales et duales celles données
  9. C en argument CH*4
  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 MATRIK2 = 'KOPS' 'EXTRINCO' MATRIK1 LMOT1 LMOT2 ;
  24. C
  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. POINTEUR MATIN.MATRIK
  41. POINTEUR MATOUT.MATRIK
  42. POINTEUR IMATIN.IMATRI
  43. POINTEUR IMATOU.IMATRI
  44. -INC SMLMOTS
  45. POINTEUR LINCP.MLMOTS
  46. POINTEUR LINCD.MLMOTS
  47. *
  48. LOGICAL OKP,OKD,OKT
  49. *
  50. INTEGER IMPR,IRET
  51. *
  52. CHARACTER*4 MOTP,MOTD
  53. PARAMETER (NMOT=2)
  54. *
  55. * Executable statements
  56. *
  57. IMPR=0
  58. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans exinck.eso'
  59. C SEGPRT,LINCP
  60. C SEGPRT,LINCD
  61. *
  62. *
  63. *
  64. SEGACT LINCP
  65. SEGACT LINCD
  66. SEGACT,MATIN
  67. NMATRI=MATIN.IRIGEL(/2)
  68. NRIGE=MATIN.IRIGEL(/1)
  69. NKID=MATIN.KIDMAT(/1)
  70. NKMT=MATIN.KKMMT(/1)
  71. *
  72. SEGINI,MATOUT
  73. IMOU=0
  74. DO IMIN=1,NMATRI
  75. * WRITE(IOIMP,*) 'IMIN=',IMIN
  76. IMATIN=MATIN.IRIGEL(4,IMIN)
  77. SEGACT IMATIN
  78. NBSOUS=IMATIN.LIZAFM(/1)
  79. NBMIN=IMATIN.LIZAFM(/2)
  80. NBMOU=0
  81. *
  82. * Y a-t-il des inconnues intéressantes ?
  83. *
  84. DO IBMIN=1,NBMIN
  85. MOTP=IMATIN.LISPRI(IBMIN)(1:4)
  86. MOTD=IMATIN.LISDUA(IBMIN)(1:4)
  87. CALL FIMOT2(MOTP,LINCP.MOTS,LINCP.MOTS(/2),IMOTP,
  88. $ IMPR,IRET)
  89. IF (IRET.NE.0) GOTO 9999
  90. CALL FIMOT2(MOTD,LINCD.MOTS,LINCD.MOTS(/2),IMOTD,
  91. $ IMPR,IRET)
  92. IF (IRET.NE.0) GOTO 9999
  93. OKP = (IMOTP.NE.0)
  94. OKD = (IMOTD.NE.0)
  95. OKT =(OKP.AND.OKD)
  96. IF (OKT) NBMOU=NBMOU+1
  97. C WRITE(IOIMP,*) 'IMOTP=',IMOTP,' IMOTD=',IMOTD
  98. C WRITE(IOIMP,*) 'MOTP=',MOTP,' MOTD=',MOTD,' OKT=',OKT
  99. ENDDO
  100. * WRITE(IOIMP,*) 'toto NBMOU=',NBMOU
  101. *
  102. * Si oui, on remplit, sinon on passe à la suite
  103. *
  104. IF (NBMOU.GT.0) THEN
  105. NBME=NBMOU
  106. SEGINI,IMATOU
  107. IBMOU=0
  108. DO IBMIN=1,NBMIN
  109. MOTP=IMATIN.LISPRI(IBMIN)(1:4)
  110. MOTD=IMATIN.LISDUA(IBMIN)(1:4)
  111. CALL FIMOT2(MOTP,LINCP.MOTS,LINCP.MOTS(/2),IMOTP,
  112. $ IMPR,IRET)
  113. IF (IRET.NE.0) GOTO 9999
  114. CALL FIMOT2(MOTD,LINCD.MOTS,LINCD.MOTS(/2),IMOTD,
  115. $ IMPR,IRET)
  116. IF (IRET.NE.0) GOTO 9999
  117. OKP = (IMOTP.NE.0)
  118. OKD = (IMOTD.NE.0)
  119. OKT =(OKP.AND.OKD)
  120. IF (OKT) THEN
  121. IBMOU=IBMOU+1
  122. IMATOU.LISPRI(IBMOU)=IMATIN.LISPRI(IBMIN)
  123. IMATOU.LISDUA(IBMOU)=IMATIN.LISDUA(IBMIN)
  124. DO IBSOUS=1,NBSOUS
  125. IMATOU.LIZAFM(IBSOUS,IBMOU)=
  126. $ IMATIN.LIZAFM(IBSOUS,IBMIN)
  127. ENDDO
  128. ENDIF
  129. ENDDO
  130. IMATOU.KSPGP=IMATIN.KSPGP
  131. IMATOU.KSPGD=IMATIN.KSPGD
  132. SEGDES,IMATOU
  133. IMOU=IMOU+1
  134. * WRITE(IOIMP,*) 'IMOU=',IMOU
  135. DO IRIGE=1,7
  136. MATOUT.IRIGEL(IRIGE,IMOU)=MATIN.IRIGEL(IRIGE,IMIN)
  137. ENDDO
  138. MATOUT.IRIGEL(4,IMOU)=IMATOU
  139. ENDIF
  140. SEGDES IMATIN
  141. ENDDO
  142. * WRITE(IOIMP,*) 'tutu'
  143. *
  144. * Ajuster les dimensions
  145. *
  146. NMATRI=IMOU
  147. SEGADJ,MATOUT
  148. SEGDES MATOUT
  149. SEGDES MATIN
  150. SEGDES LINCD
  151. SEGDES LINCP
  152. *
  153. * Normal termination
  154. *
  155. * IRET=0
  156. RETURN
  157. *
  158. * Format handling
  159. *
  160. *
  161. * Error handling
  162. *
  163. 9999 CONTINUE
  164. * IRET=1
  165. WRITE(IOIMP,*) 'An error was detected in subroutine exinck'
  166. CALL ERREUR(5)
  167. RETURN
  168. *
  169. * End of subroutine EXINCK
  170. *
  171. END
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  

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