Esope source files

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