Sources Esope | Cast3M

prcmck
C PRCMCK    SOURCE    CB215821  20/11/25    13:36:03     10792          
      SUBROUTINE PRCMCK(MATC,MATB,CHPOD,MATCDB,IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : PRCMCK
C DESCRIPTION : Préparation du calcul de CD-1Bt, on effectue les boucles
C               sur les matrices élémentaires.
C
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          : PROMAT
C APPELES (E/S)    : LIROBJ, ECROBJ
C APPELES (STAT)   : INMSTA, PRMSTA, SUMSTA
C APPELE PAR       : RYO2V
C***********************************************************************
C SYNTAXE GIBIANE    : MATCDB = 'KOPS' 'CMCT' MATC MATB CHPOD
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 28/01/2000, version initiale réécrite
C HISTORIQUE : v1, 28/01/2000, 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
*
* MATC, MATB, MATCDB : les deux matrices à multiplier et leur produit
*
-INC SMMATRIK
      INTEGER NRIGE,NMATRI,NKID,NKMT
      POINTEUR MATC.MATRIK
      POINTEUR MATB.MATRIK
      POINTEUR MATCDB.MATRIK
      POINTEUR IMATC.IMATRI
      POINTEUR IMATB.IMATRI
      POINTEUR IMTCDB.IMATRI
-INC SMELEME
      POINTEUR MPRIC.MELEME,MDUAC.MELEME
      POINTEUR MPRIB.MELEME,MDUAB.MELEME
      POINTEUR MPCDB.MELEME,MDCDB.MELEME
C      POINTEUR MPCDB1.MELEME,MDCDB1.MELEME
*
* Les segments relatifs à la matrice diagonale D
*
-INC SMCHPOI
      POINTEUR CHPOD.MCHPOI
*
* Includes persos
*
C      SEGMENT MELS
C      POINTEUR LISMEL(NBMEL).MELEME
C      ENDSEGMENT
C      INTEGER NBMEL
C      POINTEUR GPMELS.MELS
*STAT-INC SMSTAT
*STAT      POINTEUR MSTOT.MSTAT
*STAT      POINTEUR MSMAT.MSTAT
*
      INTEGER IMPR,IRET
*
      INTEGER NMEB,NMEC
      INTEGER IMEB,IMEC
*
* Executable statements
*
*STAT      CALL INMSTA(MSTOT,0)
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prcmck.eso'
      SEGACT MATB
      NMEB=MATB.IRIGEL(/2)
      SEGACT MATC
      NMEC=MATC.IRIGEL(/2)
      NRIGE=7
      NMATRI=0
      NKID=9
      NKMT=7
      SEGINI MATCDB
      DO 1 IMEB=1,NMEB
         MPRIB=MATB.IRIGEL(1,IMEB)
         MDUAB=MATB.IRIGEL(2,IMEB)
         IMATB=MATB.IRIGEL(4,IMEB)
         DO 12 IMEC=1,NMEC
* Vérification des noms d'inconnues
            MPRIC=MATC.IRIGEL(1,IMEC)
            MDUAC=MATC.IRIGEL(2,IMEC)
            IMATC=MATC.IRIGEL(4,IMEC)
*STAT            CALL INMSTA(MSMAT,0)
            CALL PROMAT(MPRIB,MDUAB,IMATB,
     $           MPRIC,MDUAC,IMATC,
     $           CHPOD,
     $           MPCDB,MDCDB,IMTCDB,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*STAT            CALL PRMSTA('  Création matrice produit',MSMAT,1)
*STAT            CALL SUMSTA(MSMAT,0)
            IF (IMTCDB.NE.0) THEN
               NMATRI=MATCDB.IRIGEL(/2)+1
               SEGADJ,MATCDB
               MATCDB.IRIGEL(1,NMATRI)=MPCDB
               MATCDB.IRIGEL(2,NMATRI)=MDCDB
               MATCDB.IRIGEL(4,NMATRI)=IMTCDB
               IF (MATB.EQ.MATC) THEN
                  MATCDB.IRIGEL(7,NMATRI)=0
               ELSE
                  MATCDB.IRIGEL(7,NMATRI)=2
               ENDIF
* Inutile avec le nouvel assemblage
C               SEGACT IMTCDB*MOD
C               NBMEL=1
C               SEGINI GPMELS
C               GPMELS.LISMEL(1)=MPCDB
C               CALL MLUNIQ(GPMELS,
C     $              MPCDB1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               IMTCDB.KSPGP=MPCDB1
C               SEGACT GPMELS*MOD
C               GPMELS.LISMEL(1)=MDCDB
C               SEGDES GPMELS
C               CALL MLUNIQ(GPMELS,
C     $              MDCDB1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               IMTCDB.KSPGD=MDCDB1
C               SEGSUP GPMELS
C               SEGDES IMTCDB
            ENDIF
 12      CONTINUE
 1    CONTINUE
      IF (MATCDB.IRIGEL(/2).EQ.0) THEN
         WRITE(IOIMP,*) 'Opérateur CMCT : la matrice produit est vide'
      ENDIF
      SEGDES MATCDB
      SEGDES MATC
      SEGDES MATB
*STAT      CALL PRMSTA('Total de CMCT',MSTOT,1)
*STAT      CALL SUMSTA(MSTOT,0)
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine prcmck'
      RETURN
*
* End of subroutine PRCMCK
*
      END