Sources Esope | Cast3M

exinck
C EXINCK    SOURCE    CB215821  20/11/04    21:16:59     10766          
      SUBROUTINE EXINCK(MATIN,LINCP,LINCD,MATOUT,IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : EXINCK
C DESCRIPTION : Extrait d'un MATRIK la sous-matrice
C               d'inconnues primales et duales celles données
C               en argument CH*4
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C    MATRIK2  = 'KOPS'  'EXTRINCO'  MATRIK1 LMOT1 LMOT2 ;
C
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 10/05/2006, version initiale
C HISTORIQUE : v1, 10/05/2006, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMMATRIK
      POINTEUR MATIN.MATRIK
      POINTEUR MATOUT.MATRIK
      POINTEUR IMATIN.IMATRI
      POINTEUR IMATOU.IMATRI
-INC SMLMOTS
      POINTEUR LINCP.MLMOTS
      POINTEUR LINCD.MLMOTS
*
      LOGICAL OKP,OKD,OKT
*
      INTEGER IMPR,IRET
*
      CHARACTER*(LOCOMP) MOTP,MOTD
      PARAMETER (NMOT=2)
*
* Executable statements
*
      IMPR=0
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans exinck.eso'
C      SEGPRT,LINCP
C      SEGPRT,LINCD
*
*
*
      SEGACT LINCP
      SEGACT LINCD
      SEGACT,MATIN
      NMATRI=MATIN.IRIGEL(/2)
      NRIGE=MATIN.IRIGEL(/1)
      NKID=MATIN.KIDMAT(/1)
      NKMT=MATIN.KKMMT(/1)
*
      SEGINI,MATOUT
      IMOU=0
      DO IMIN=1,NMATRI
*         WRITE(IOIMP,*) 'IMIN=',IMIN
         IMATIN=MATIN.IRIGEL(4,IMIN)
         SEGACT IMATIN
         NBSOUS=IMATIN.LIZAFM(/1)
         NBMIN=IMATIN.LIZAFM(/2)
         NBMOU=0
*
* Y a-t-il des inconnues intéressantes ?
*
         DO IBMIN=1,NBMIN
            MOTP=IMATIN.LISPRI(IBMIN)(1:4)
            MOTD=IMATIN.LISDUA(IBMIN)(1:4)
            CALL FIMOT2(MOTP,LINCP.MOTS,LINCP.MOTS(/2),IMOTP,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            CALL FIMOT2(MOTD,LINCD.MOTS,LINCD.MOTS(/2),IMOTD,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            OKP = (IMOTP.NE.0)
            OKD = (IMOTD.NE.0)
            OKT =(OKP.AND.OKD)
            IF (OKT) NBMOU=NBMOU+1
C            WRITE(IOIMP,*) 'IMOTP=',IMOTP,' IMOTD=',IMOTD
C            WRITE(IOIMP,*) 'MOTP=',MOTP,' MOTD=',MOTD,' OKT=',OKT
         ENDDO
*         WRITE(IOIMP,*) 'toto NBMOU=',NBMOU
*
* Si oui, on remplit, sinon on passe à la suite
*
         IF (NBMOU.GT.0) THEN
            NBME=NBMOU
            SEGINI,IMATOU
            IBMOU=0
            DO IBMIN=1,NBMIN
               MOTP=IMATIN.LISPRI(IBMIN)(1:4)
               MOTD=IMATIN.LISDUA(IBMIN)(1:4)
               CALL FIMOT2(MOTP,LINCP.MOTS,LINCP.MOTS(/2),IMOTP,
     $              IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               CALL FIMOT2(MOTD,LINCD.MOTS,LINCD.MOTS(/2),IMOTD,
     $              IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               OKP = (IMOTP.NE.0)
               OKD = (IMOTD.NE.0)
               OKT =(OKP.AND.OKD)
               IF (OKT) THEN
                  IBMOU=IBMOU+1
                  IMATOU.LISPRI(IBMOU)=IMATIN.LISPRI(IBMIN)
                  IMATOU.LISDUA(IBMOU)=IMATIN.LISDUA(IBMIN)
                  DO IBSOUS=1,NBSOUS
                     IMATOU.LIZAFM(IBSOUS,IBMOU)=
     $                    IMATIN.LIZAFM(IBSOUS,IBMIN)
                  ENDDO
               ENDIF
            ENDDO
            IMATOU.KSPGP=IMATIN.KSPGP
            IMATOU.KSPGD=IMATIN.KSPGD
            SEGDES,IMATOU
            IMOU=IMOU+1
*            WRITE(IOIMP,*) 'IMOU=',IMOU
            DO IRIGE=1,7
               MATOUT.IRIGEL(IRIGE,IMOU)=MATIN.IRIGEL(IRIGE,IMIN)
            ENDDO
            MATOUT.IRIGEL(4,IMOU)=IMATOU
         ENDIF
         SEGDES IMATIN
      ENDDO
*      WRITE(IOIMP,*) 'tutu'
*
* Ajuster les dimensions
*
      NMATRI=IMOU
      SEGADJ,MATOUT
      SEGDES MATOUT
      SEGDES MATIN
      SEGDES LINCD
      SEGDES LINCP
*
* Normal termination
*
*      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
*      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine exinck'
      CALL ERREUR(5)
      RETURN
*
* End of subroutine EXINCK
*
      END