Esope source files

   1 : C PRCMCK    SOURCE    GOUNAND   11/05/24    21:15:46     6976           
   2 :       SUBROUTINE PRCMCK(MATC,MATB,CHPOD,MATCDB,IMPR,IRET)
   3 :       IMPLICIT REAL*8 (A-H,O-Z)
   4 :       IMPLICIT INTEGER (I-N)
   5 : C***********************************************************************
   6 : C NOM         : PRCMCK
   7 : C DESCRIPTION : Préparation du calcul de CD-1Bt, on effectue les boucles
   8 : C               sur les matrices élémentaires.  
   9 : C
  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          : PROMAT
  17 : C APPELES (E/S)    : LIROBJ, ECROBJ
  18 : C APPELES (STAT)   : INMSTA, PRMSTA, SUMSTA
  19 : C APPELE PAR       : RYO2V
  20 : C***********************************************************************
  21 : C SYNTAXE GIBIANE    : MATCDB = 'KOPS' 'CMCT' MATC MATB CHPOD
  22 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  23 : C***********************************************************************
  24 : C VERSION    : v1, 28/01/2000, version initiale réécrite
  25 : C HISTORIQUE : v1, 28/01/2000, création
  26 : C HISTORIQUE :
  27 : C HISTORIQUE :
  28 : C***********************************************************************
  29 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  30 : C en cas de modification de ce sous-programme afin de faciliter
  31 : C la maintenance !
  32 : C***********************************************************************
  33 : -INC CCOPTIO
  34 : *     
  35 : * MATC, MATB, MATCDB : les deux matrices à multiplier et leur produit
  36 : *     
  37 : -INC SMMATRIK
  38 :       INTEGER NRIGE,NMATRI,NKID,NKMT
  39 :       POINTEUR MATC.MATRIK
  40 :       POINTEUR MATB.MATRIK
  41 :       POINTEUR MATCDB.MATRIK
  42 :       POINTEUR IMATC.IMATRI
  43 :       POINTEUR IMATB.IMATRI
  44 :       POINTEUR IMTCDB.IMATRI
  45 : -INC SMELEME
  46 :       POINTEUR MPRIC.MELEME,MDUAC.MELEME
  47 :       POINTEUR MPRIB.MELEME,MDUAB.MELEME
  48 :       POINTEUR MPCDB.MELEME,MDCDB.MELEME
  49 : C      POINTEUR MPCDB1.MELEME,MDCDB1.MELEME
  50 : *     
  51 : * Les segments relatifs à la matrice diagonale D
  52 : *     
  53 : -INC SMCHPOI
  54 :       POINTEUR CHPOD.MCHPOI
  55 : *     
  56 : * Includes persos
  57 : *     
  58 : C      SEGMENT MELS
  59 : C      POINTEUR LISMEL(NBMEL).MELEME
  60 : C      ENDSEGMENT
  61 : C      INTEGER NBMEL
  62 : C      POINTEUR GPMELS.MELS
  63 : *STAT-INC SMSTAT
  64 : *STAT      POINTEUR MSTOT.MSTAT
  65 : *STAT      POINTEUR MSMAT.MSTAT
  66 : *
  67 :       INTEGER IMPR,IRET
  68 : *
  69 :       INTEGER NMEB,NMEC
  70 :       INTEGER IMEB,IMEC
  71 : *     
  72 : * Executable statements
  73 : *
  73 : *STAT      CALL INMSTA(MSTOT,0)
  74 :       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prcmck.eso' 
  75 :       SEGACT MATB
  76 :       NMEB=MATB.IRIGEL(/2)
  77 :       SEGACT MATC
  78 :       NMEC=MATC.IRIGEL(/2)
  79 :       NRIGE=7
  80 :       NMATRI=0
  81 :       NKID=9
  82 :       NKMT=7
  83 :       SEGINI MATCDB
  84 :       DO 1 IMEB=1,NMEB
  85 :          MPRIB=MATB.IRIGEL(1,IMEB)
  86 :          MDUAB=MATB.IRIGEL(2,IMEB)
  87 :          IMATB=MATB.IRIGEL(4,IMEB)
  88 :          DO 12 IMEC=1,NMEC
  89 : * Vérification des noms d'inconnues
  90 :             MPRIC=MATC.IRIGEL(1,IMEC)
  91 :             MDUAC=MATC.IRIGEL(2,IMEC)
  92 :             IMATC=MATC.IRIGEL(4,IMEC)
  92 : *STAT            CALL INMSTA(MSMAT,0)
  92 :             CALL PROMAT(MPRIB,MDUAB,IMATB,
  93 :      $           MPRIC,MDUAC,IMATC,
  94 :      $           CHPOD,
  95 :      $           MPCDB,MDCDB,IMTCDB,
  96 :      $           IMPR,IRET)
  97 :             IF (IRET.NE.0) GOTO 9999
  97 : *STAT            CALL PRMSTA('  Création matrice produit',MSMAT,1)
  97 : *STAT            CALL SUMSTA(MSMAT,0)
  98 :             IF (IMTCDB.NE.0) THEN
  99 :                NMATRI=MATCDB.IRIGEL(/2)+1
 100 :                SEGADJ,MATCDB
 101 :                MATCDB.IRIGEL(1,NMATRI)=MPCDB
 102 :                MATCDB.IRIGEL(2,NMATRI)=MDCDB
 103 :                MATCDB.IRIGEL(4,NMATRI)=IMTCDB
 104 :                IF (MATB.EQ.MATC) THEN 
 105 :                   MATCDB.IRIGEL(7,NMATRI)=0
 106 :                ELSE
 107 :                   MATCDB.IRIGEL(7,NMATRI)=2
 108 :                ENDIF
 109 : * Inutile avec le nouvel assemblage
 110 : C               SEGACT IMTCDB*MOD
 111 : C               NBMEL=1
 112 : C               SEGINI GPMELS
 113 : C               GPMELS.LISMEL(1)=MPCDB
 113 : C               CALL MLUNIQ(GPMELS,
 114 : C     $              MPCDB1,IMPR,IRET)
 115 : C               IF (IRET.NE.0) GOTO 9999
 116 : C               IMTCDB.KSPGP=MPCDB1
 117 : C               SEGACT GPMELS*MOD
 118 : C               GPMELS.LISMEL(1)=MDCDB
 119 : C               SEGDES GPMELS
 119 : C               CALL MLUNIQ(GPMELS,
 120 : C     $              MDCDB1,IMPR,IRET)
 121 : C               IF (IRET.NE.0) GOTO 9999
 122 : C               IMTCDB.KSPGD=MDCDB1
 123 : C               SEGSUP GPMELS
 124 : C               SEGDES IMTCDB
 125 :             ENDIF
 126 :  12      CONTINUE
 127 :  1    CONTINUE
 128 :       IF (MATCDB.IRIGEL(/2).EQ.0) THEN
 129 :          WRITE(IOIMP,*) 'Opérateur CMCT : la matrice produit est vide'
 130 :       ENDIF
 131 :       SEGDES MATCDB
 132 :       SEGDES MATC
 133 :       SEGDES MATB
 133 : *STAT      CALL PRMSTA('Total de CMCT',MSTOT,1)      
 133 : *STAT      CALL SUMSTA(MSTOT,0)      
 134 : *
 135 : * Normal termination
 136 : *
 137 :       IRET=0
 138 :       RETURN
 139 : *
 140 : * Format handling
 141 : *
 142 : *
 143 : * Error handling
 144 : *
 145 :  9999 CONTINUE
 146 :       IRET=1
 147 :       WRITE(IOIMP,*) 'An error was detected in subroutine prcmck'
 148 :       RETURN
 149 : *
 150 : * End of subroutine PRCMCK
 151 : *
 152 :       END
 153 : 
 154 :