[updated 23.Mar.2010]
Librairie assembl > Fichier matmat.f |
SUBROUTINE MATMAT (NMMATG,NVMATG,NMMATD,NVMATD
& ,NMPROD,NVPROD,NIVIMP)
Auteur : D.Martin (Juin 2008)
Derniere modification : D.Martin (8 decembre 2009)
Version 1
Multiplication MG * ML : Matrice quelconque x Matrice quelconque
N.B. Tous les types de stockage ne sont pas encore;>) envisages;
actuellement l'une au moins des matrices est supposée stockee pleine
-- Arguments d'entree --
NMMATG nom du terme matriciel operande à gauche MG
NVMATG son niveau
NMMATD nom du terme matriciel operande à droite ML
NVMATD son niveau
NMPROD nom du terme matriciel resultat du produit MG * ML
NVPROD niveau du terme resultat
NIVIMP niveau d'impression du terme resultat
IMPLICIT NONE
CHARACTER*(*) NMMATG,NMMATD,NMPROD
INTEGER NVMATG,NVMATD,NVPROD,NIVIMP
INCLUDE 'CONTEX'
INCLUDE 'ALLOC'
INTEGER INDASS,INDSTO,INTYKL,INTTYP,KLTERM
INTEGER MCMTRM,MCDTRM,LGETRM,NBTERM,INCTRM,NCHTRM,NUTERM,ADTERM
& ,ITYPMG,ITYCAL,NUKALE,NUDONN,ITYSMG,NVDSMG,NUICMG,NVDCMG
& ,NBCOLG,NVNCMG,NUILMG,NVDLMG,NBLIGG,NVNLMG,INDSTG,NVSTOG
& ,IATRDG,LGMATG,MCMATG,MCSTOG,NVCOOR
& ,ITYPTD,ITYCAD,NUKALD,NUDOND,ITYSMD,NVDSMD,NUICMD,NVDCMD
& ,NBCOLD,NVNCMD,NUILMD,NVDLMD,NBLIGD,NVNLMD,INDSTD,NVSTOD
& ,IATRDD,LGMATD,MCMATD,MCSTOD
& ,ITYPTR,LGPROD,MCPROD,INSTOK,NVSTOK,MCSTOK
& ,NIVIMR,NIVEAU,NCATR1,NCATR2,NCATR3
LOGICAL IDMTRM, CRETRM
CHARACTER PRFXAS*8,TYPINT*8
CHARACTER*6 STOCHN,NMSTOG,NMSTOD,NMSTOK
CHARACTER*8 TYMATG,TYMATD,TYPROD
CHARACTER MULTIG,MULTID,ERCODE*120
COMMON/FORMAH/ERCODE
CALL PRFXMJ (1,'*MatMat*')
CRETRM=.TRUE.
IDMTRM=.FALSE.
IF (NIVIMP.GE.0.AND.IMPSDR.GT.0) THEN
CALL PRNTRM (NMPROD,NVPROD,ERCODE,NCATR1)
CALL PRNTRM (NMMATG,NVMATG,ERCODE(NCATR1+1:),NCATR2)
CALL PRNTRM (NMMATD,NVMATD,ERCODE(NCATR1+NCATR2+1:),NCATR3)
WRITE (IMPSDR,10000) PRFXAS (0),ERCODE(1:NCATR1)
& ,ERCODE(NCATR1+1:NCATR1+NCATR2)
& ,ERCODE(NCATR1+NCATR2+1:NCATR1+NCATR2+NCATR3)
ENDIF
CALL TBAR2 (ERCODE,'#OMTRM',1,MCMTRM,'$SDTRM',1,MCDTRM)
CALL SDEXDB (IST(MCDTRM),LGETRM,NBTERM,INCTRM,NCHTRM) !utilite
Caracteristiques de la matrice operande a gauche
NUTERM=KLTERM (NMMATG,NVMATG,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTERM.LE.0) CALL ERTERM (1,NMMATG,NVMATG) !utilite
ADTERM=MCDTRM+LGETRM+INCTRM*(NUTERM-1)
CALL GETTRM (IST(ADTERM) ,NIVEAU,ITYPMG,ITYCAL,NUKALE,NUDONN
& ,ITYSMG,NVDSMG,NUICMG,NVDCMG,NBCOLG,NVNCMG,NUILMG
& ,NVDLMG,NBLIGG,NVNLMG,INDSTG,NVSTOG,NVCOOR,IATRDG
& ,NIVIMR) !sdexplo
TYMATG=TYPINT (ITYPMG)
MULTIG='N'
IF (NVDSMG.NE.NDFDSM.AND.NUICMG.EQ.NDFINC.AND.NUILMG.EQ.NDFINC)
& MULTIG='Y'
NMSTOG=STOCHN (INDSTG)
Caracteristiques de vecteur (matrice diagonale, operande a droite)
NUTERM=KLTERM (NMMATD,NVMATD,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTERM.LE.0) CALL ERTERM (1,NMMATD,NVMATD) !utilite
ADTERM=MCDTRM+LGETRM+INCTRM*(NUTERM-1)
CALL GETTRM (IST(ADTERM) ,NIVEAU,ITYPTD,ITYCAL,NUKALD,NUDOND
& ,ITYSMD,NVDSMD,NUICMD,NVDCMD,NBCOLD,NVNCMD,NUILMD
& ,NVDLMD,NBLIGD,NVNLMD,INDSTD,NVSTOD,NVCOOR,IATRDD
& ,NIVIMR) !sdexpl
TYMATD=TYPINT (ITYPTD)
MULTID='N'
IF (NVDSMD.NE.NDFDSM.AND.NUICMD.EQ.NDFINC.AND.NUILMD.EQ.NDFINC)
& MULTID='Y'
NMSTOD=STOCHN (INDSTD)
IF (MULTIG.EQ.'Y'.OR.MULTID.EQ.'Y') GOTO 99991
IF (NBCOLG.NE.NBLIGD) CALL ERTERS (7,NMMATG,NVMATG,NMMATD,NVMATD) !utilite
Type, longueur de la matrice resultat
TYPROD=TYMATG
IF (TYMATD(1:2).EQ.'CO') TYPROD=TYMATD
ITYPTR= INTTYP (TYPROD) !utilite
Si l'une des matrices operandes est PLEINE
la matrice resultat est stockee PLEIN-C
INSTOK=INDSTO('PLEIN-C')
NMSTOK='PLEINC'
IF (NMSTOD.EQ.'PLEINL') THEN
Matrice à droite PLEINE
NVSTOK=NDFSTO
LGPROD=NBLIGG*NBCOLD
ELSEIF (NMSTOG.EQ.'PLEINL') THEN
Matrice à gauche PLEINE
NVSTOK=NDFSTO
LGPROD=NBLIGG*NBCOLD
ELSE
GOTO 99992
ENDIF
CALL TBRR2 (ERCODE,NMMATD,NVMATD,LGMATD,NMMATG,NVMATG,LGMATG)
IF (NMSTOG(1:2).NE.'PL') CALL TBRR1 (ERCODE,NMSTOG,NVSTOG,MCSTOK)
IF (NMSTOD(1:2).NE.'PL') CALL TBRR1 (ERCODE,NMSTOD,NVSTOG,MCSTOK)
ITYCAL= INTYKL ('ASSEMB') !utilite
NUKALE=-INDASS (' ') !utilite
MCSTOG=0
IF (NMSTOG(1:2).NE.'PL') CALL TBAR1 (ERCODE,NMSTOG,NVSTOG,MCSTOG)
MCSTOD=0
IF (NMSTOD(1:2).NE.'PL') CALL TBAR1 (ERCODE,NMSTOD,NVSTOD,MCSTOD)
CALL CRTERM (NMPROD,NVPROD,LGPROD,ITYPTR,ITYCAL,NUKALE,NDFDON
& ,NDFSYM,NVDSMD
& ,NUICMD,NVDCMD,NBCOLD,NVNCMD
& ,NUILMG,NVDLMG,NBLIGG,NVNLMG,INSTOK,NDFSTO,NDFCOR
& ,IATRDG,NIVIMP,IDMTRM,CRETRM) !sdexplo
-- Adresse des operandes et du tableau de pointeurs de la matrice
CALL TBAR3 (ERCODE,NMMATD,NVMATD,MCMATD,NMMATG,NVMATG,MCMATG
& ,NMPROD,NVPROD,MCPROD)
IF (NMSTOD.EQ.'PLEINL') THEN
Matrice a gauche quelconque, Matrice a droite stockee PLEIN_L
CALL MATMPC(NBLIGG,NBCOLG
& ,NMSTOG,MCSTOG,ITYSMG,TYMATG,MCMATG
& ,NBCOLD,TYMATD,MCMATD
& ,TYPROD,MCPROD,IST,RST,CST)
ELSE IF (NMSTOG.EQ.'PLEINL') THEN
Matrice a gauche stockee PLEIN_L, Matrice a droite quelconque
On pourrait calculer le produit des transposées, puis transposer
le resultat obtenu
GOTO 99992
ENDIF
IF (NIVIMP.GT.0) CALL PRTERM (NMPROD,NVPROD,NIVIMP,IMPSDR) !prsd
CALL TBSAVE (NMMATG,NVMATG)
CALL TBSAVE (NMMATD,NVMATD)
CALL TBSAVE (NMPROD,NVPROD)
CALL PRFXMJ (-1,'*MatMat*')
RETURN
10000 FORMAT(/T2,A8,' Produit matrice x matrice ',A:
&/T11,'matrice ',A,' * matrice ',A)
99991 NCATR1=0
CALL PRNTRM (NMMATG,NVMATG,ERCODE(NCATR1+1:),NCATR2)
CALL PRNTRM (NMMATD,NVMATD,ERCODE(NCATR1+NCATR2+1:),NCATR3)
CALL BAISE (' Multiplication matrice x matrice non prevue'
&//' pour des matrices non-uni-inconnue : '
&//ERCODE(NCATR1+1:NCATR1+NCATR2)//' et '
&//ERCODE(NCATR1+NCATR2+1:NCATR1+NCATR2+NCATR3))
99992 NCATR1=0
CALL PRNTRM (NMMATG,NVMATG,ERCODE(NCATR1+1:),NCATR2)
CALL PRNTRM (NMMATD,NVMATD,ERCODE(NCATR1+NCATR2+1:),NCATR3)
CALL BAISE (' Multiplication matrice x matrice non prevue'
&//' pour le stockage '//NMSTOG(1:6)//' de la matrice '
&//ERCODE(NCATR1+1:NCATR1+NCATR2)
&//' ou le stockage '//NMSTOD(1:6)//' de la matrice '
&//ERCODE(NCATR1+NCATR2+1:NCATR1+NCATR2+NCATR3))
-- File history
Version 1 : D.Martin (8 decembre 2009)
oups ! nombre de lignes et colonnes intervertis dans CRTERM
Version 0 : D.Martin (16 juin 2009)
END !MatMat
