Sources Esope | Cast3M

machik
C MACHIK    SOURCE    PV        20/09/26    21:18:41     10724          
      SUBROUTINE MACHIK(EMTK,EPRI,SPRI,EDUA,SDUA,SMTK)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : MACHIK
C DESCRIPTION : Changement de nom d'inconnues primales et duales
C               d'une matrice (type RIGIDITE ou MATRIK)
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)    : LIROBJ
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C    MATRIK2  = 'KOPS'  'CHANINCO'  MATRIK1
C                        LISTMOT1 LISTMOT2 LISTMOT3 LISTMOT4 ;
C ENTREES            : EMTK
C ENTREES/SORTIES    : -
C SORTIES            : SMTK
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 04/07/2002, version initiale
C HISTORIQUE : v1, 04/07/2002, 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 SMLMOTS
      POINTEUR EPRI.MLMOTS
      POINTEUR EDUA.MLMOTS
      POINTEUR SPRI.MLMOTS
      POINTEUR SDUA.MLMOTS
-INC SMMATRIK
      POINTEUR EMTK.MATRIK
      POINTEUR SMTK.MATRIK
      POINTEUR EIMAT.IMATRI
      POINTEUR SIMAT.IMATRI
*
      INTEGER IRETOU
      INTEGER LEPRI,LSPRI,LEDUA,LSDUA
      INTEGER IEPRI,IEDUA
      INTEGER NRIGE,NMATRI,NKID,NKMT,NBME
      INTEGER IRIGE,JMATRI,          IBME
*
* Executable statements
*
*
* Lecture des arguments
*
      SEGACT,EPRI,SPRI,EDUA,SDUA
      LEPRI=EPRI.MOTS(/2)
      LSPRI=SPRI.MOTS(/2)
      LEDUA=EDUA.MOTS(/2)
      LSDUA=SDUA.MOTS(/2)
      IF (LEPRI.NE.LSPRI.OR.LEDUA.NE.LSDUA) THEN
         CALL ERREUR(854)
         RETURN
      ENDIF
*
* Initialisation du chapeau Matrik résultat et mise à zéro
* de toute information de préconditionnement.
*
      SEGACT EMTK
      NRIGE=EMTK.IRIGEL(/1)
      NMATRI=EMTK.IRIGEL(/2)
      NKID=EMTK.KIDMAT(/1)
      NKMT=EMTK.KKMMT(/1)
      SEGINI,SMTK
      DO JMATRI=1,NMATRI
         DO IRIGE=1,NRIGE
            SMTK.IRIGEL(IRIGE,JMATRI)=EMTK.IRIGEL(IRIGE,JMATRI)
         ENDDO
* On ne sait pas si la matrice résultante est symétrique
* (et on s'en fout)
* mais c'est mieux de garder le type !
*         SMTK.IRIGEL(7,JMATRI)=3
      ENDDO
      SEGDES,EMTK
*
* Duplication des segments IMATRI et changement éventuel des noms
* d'inconnues
*
      DO JMATRI=1,NMATRI
         EIMAT=SMTK.IRIGEL(4,JMATRI)
         SEGINI,SIMAT=EIMAT
         SMTK.IRIGEL(4,JMATRI)=SIMAT
         NBME=SIMAT.LIZAFM(/2)
         DO IBME=1,NBME
            DO IEPRI=1,LEPRI
               IF (SIMAT.LISPRI(IBME)(1:4).EQ.EPRI.MOTS(IEPRI)(1:4))
     $              THEN
                  SIMAT.LISPRI(IBME)(1:4)=SPRI.MOTS(IEPRI)(1:4)
               ENDIF
            ENDDO
            DO IEDUA=1,LEDUA
               IF (SIMAT.LISDUA(IBME)(1:4).EQ.EDUA.MOTS(IEDUA)(1:4))
     $              THEN
                  SIMAT.LISDUA(IBME)(1:4)=SDUA.MOTS(IEDUA)(1:4)
               ENDIF
            ENDDO
         ENDDO
         SEGDES,SIMAT
      ENDDO
      SEGDES,SMTK
      SEGDES,EPRI,SPRI,EDUA,SDUA
*
* Normal termination
*
      RETURN
*
* Format handling
*
*
* End of subroutine MACHIK
*
      END