[updated 8.Sep.2008]
Librairie assembl > Fichier clterm.f |
SUBROUTINE CLTERM (NMTRM1,NVTRM1,NMDON1,NMTRM2,NVTRM2,NMDON2
& ,NMTRM3,NVTRM3,NIVIMP)
Auteur : D.Martin (Novembre 1991)
Derniere modification : D.Martin (27 Juin 2000)
Version 1.0.3
Combinaison lineaire de termes : t3 = a1.t1 + a2.t2
La combinaison utilise la donnee ai=NMDONi si la chaine NMDONi est non blanche
dans ce cas NMDONi est necessairement une constante.
Si la chaine NMDONi est blanche, on utilise la donnee associee au terme NMTRMi
Si NMTRMi n'a pas de donnee CONSTANTE associee on utilise la constante 1
Toutes les combinaisons sont possibles pour t1, t2, t3, a1, a2
mais les termes t1 et t2 sont necessairement distincts.
Exemple : t3 = t1 + a2.t2 si le nom de a1 est donne vide et si le
t1 n'a pas de constante associee
-- Arguments d'entree --
NMTRM1,NVTRM1 Nom et niveau du 1er terme operande
NMDON1 Nom de la donnee multiplicative du 1er terme (le cas echeant)
NMTRM2,NVTRM2 Nom et niveau du 2nd terme operande
NMDON2 Nom de la donnee multiplicative du 1er terme (le cas echeant)
NMTRM3,NVTRM3 Nom et niveau du terme resultat
NIVIMP Niveau d'impression du terme resultat
Remarques: -- Le terme resultat n'a pas de constante associee.
-- Le terme resultat ne peut coincider avec l'un des termes
operandes que si l'operation ne modifie pas le type (REEL ou
COMPLEXE) du terme coincidant
-- Il n'aura un domaine de calcul associe que s'il coincide
avec un des deux termes operandes
-- Si les trois termes different deux a deux, les attributs
du terme resultat sont ceux du plus petit des deux premiers
et du 1er en cas d'egalite
-- Si les longueurs des termes 1 et 2 different, la combinaison
porte sur la longueur minimum et un Warning est emis
-- Si les inconnues des termes 1 et 2 ou leur type de stockage
different, un Warning est emis
CHARACTER*(*) NMTRM1,NMTRM2,NMTRM3,NMDON1,NMDON2
INTEGER NVTRM1,NVTRM2,NVTRM3,NIVIMP
INCLUDE 'CONTEX'
INCLUDE 'ALLOC'
INTEGER INDASS,INTTYP,INTDON,INTYKL,KELCHN,KLTERM
CHARACTER TYPINT*8
INTEGER MCMTRM,MCDTRM,LGETRM,NBTERM,INCTRM,NCHTRM,IADTRM
& ,NIVEAU,MCMDON,MCDONN,LGEDON,NBDONN,INCDON,NCHDON
& ,NIVIMR,LNDONN
& ,NUTER1,ITTRM1,ITYCA1,NUKAL1,NUDON1,ITYSY1,NVDSM1
& ,NUINC1,NVDUC1,NBNEC1,NVNUC1,NUINL1,NVDUL1,NBNEL1
& ,NVNUL1,INDST1,NVNUS1,NVCOO1,IATRD1,LGTRM1,MCTRM1,NCATR1
& ,ITYDO1,NIVDO1,ITYPD1,MCCST1
& ,NUTER2,ITTRM2,ITYCA2,NUKAL2,NUDON2,ITYSY2,NVDSM2
& ,NUINC2,NVDUC2,NBNEC2,NVNUC2,NUINL2,NVDUL2,NBNEL2
& ,NVNUL2,INDST2,NVNUS2,NVCOO2,IATRD2,LGTRM2,MCTRM2,NCATR2
& ,ITYDO2,NIVDO2,ITYPD2,MCCST2
& ,ITTRM3,ITYCA3,NUKAL3,LGTRM3,MCTRM3
LOGICAL IDMTR1,IDMTR2,CRETRM
CHARACTER*8 TYTRM1,TYDON1,TYTRM2,TYDON2,TYTRM3
CHARACTER ERCODE*120
COMMON/FORMAH/ERCODE
EQUIVALENCE (ERCODE(113:113),TYTRM3)
& ,(ERCODE(105:105),TYTRM1),(ERCODE(97:97),TYTRM2)
& ,(ERCODE(89:89),TYDON1) ,(ERCODE(81:81),TYDON2)
CALL PRFXMJ (1,'*ClTerm*')
IF (NMDON1(1:1).EQ.' '.AND.NMDON2(1:1).EQ.' ') THEN
CALL T2TERM (NMTRM1,NVTRM1,'cl',NMTRM2,NVTRM2
& ,NMTRM3,NVTRM3,NIVIMP) !assembl
ELSE
IF (NIVIMP.GE.0.AND.IMPSDR.GT.0) THEN
CALL PRNTRM (NMTRM3,NVTRM3,ERCODE,NCATR1)
WRITE (IMPSDR,10000) ERCODE(1:NCATR1)
ENDIF
IDMTR1=NMTRM1.EQ.NMTRM3.AND.NVTRM1.EQ.NVTRM3
IDMTR2=NMTRM2.EQ.NMTRM3.AND.NVTRM2.EQ.NVTRM3
CALL TBAR2 (ERCODE,'#OMTRM',1,MCMTRM,'$SDTRM',1,MCDTRM)
CALL SDEXDB (IST(MCDTRM),LGETRM,NBTERM,INCTRM,NCHTRM) !utilite
IF (NMTRM1.EQ.NMTRM2.AND.NVTRM1.EQ.NVTRM2)
& CALL ERTERM (9,NMTRM1,NVTRM1) !utilite
Recherche des caracteristiques des termes
NUTER1=KLTERM (NMTRM1,NVTRM1,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTER1.LE.0) CALL ERTERM (1,NMTRM1,NVTRM1) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTER1-1)
CALL GETTRM (IST(IADTRM) ,NIVEAU,ITTRM1,ITYCA1,NUKAL1,NUDON1
& ,ITYSY1,NVDSM1,NUINC1,NVDUC1,NBNEC1,NVNUC1,NUINL1
& ,NVDUL1,NBNEL1,NVNUL1,INDST1,NVNUS1
& ,NVCOO1,IATRD1,NIVIMR) !sdexplo
TYTRM1=TYPINT (ITTRM1) !utilite
NUTER2=KLTERM (NMTRM2,NVTRM2,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTER2.LE.0) CALL ERTERM (1,NMTRM2,NVTRM2) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTER2-1)
CALL GETTRM (IST(IADTRM) ,NIVEAU,ITTRM2,ITYCA2,NUKAL2,NUDON2
& ,ITYSY2,NVDSM2,NUINC2,NVDUC2,NBNEC2,NVNUC2,NUINL2
& ,NVDUL2,NBNEL2,NVNUL2,INDST2,NVNUS2
& ,NVCOO2,IATRD2,NIVIMR) !sdexplo
TYTRM2=TYPINT (ITTRM2) !utilite
CALL TBRR2 (ERCODE,NMTRM1,NVTRM1,LGTRM1,NMTRM2,NVTRM2,LGTRM2)
CALL TBAR3 (ERCODE,'$SDTRM',1,MCDTRM
& ,'#OMDON',1,MCMDON,'$DONNE',1,MCDONN)
CALL SDEXDB (IST(MCDONN),LGEDON,NBDONN,INCDON,NCHDON) !utilite
Compatibilite des attributs des termes combines
(meme(s) inconnue(s), meme type de stockage, meme longueur) ?
CALL WATERS (NMTRM1,NVTRM1,NUINC1,NUINL1,ITYSY1,INDST1,LGTRM1
& ,NMTRM2,NVTRM2,NUINC2,NUINL2,ITYSY2,INDST2,LGTRM2)
Recherche des numeros et des caracteristiques
des constantes multiplicatives de la combinaison lineaire
LNDONN=LEN (NMDON1)
ERCODE(1:LNDONN)=' '
IF (NMDON1.NE.ERCODE(1:LNDONN)) THEN
Le nom de la donnee 1 figure dans la liste des arguments,
elle est utilisee dans la combinaison lineaire
NUDON1=KELCHN (NMDON1,AST(MCMDON),NBDONN,NCHDON) !sdexplo
IF (NUDON1.LE.0) CALL ERDONN (1,NMDON1) !utilite
CALL SDEXCO (NUDON1,IST(MCDONN),ITYDO1,NIVDO1,ITYPD1) !utilite
La donnee de la liste d'entree DOIT ici etre une constante
IF (ITYDO1.NE.INTDON ('CONSTANTE')) CALL ERDONN (2,NMDON1) !utilite
ENDIF
TYDON1=' '
IF (NUDON1.GT.0) THEN
CALL SDEXCO (NUDON1,IST(MCDONN),ITYDO1,NIVDO1,ITYPD1) !utilite
Le terme peut avoir une donnee associee qui n'est pas une constante
auquel cas elle est ignoree (et remplacee par la constante 1)
IF (ITYDO1.EQ.INTDON ('CONSTANTE')) THEN
TYDON1=TYPINT (ITYPD1) !utilite
ELSE
Si on arrive ici, pas de donnee (donc la constante 1)
NUDON1=0
ENDIF
ENDIF
LNDONN=LEN (NMDON2)
ERCODE(1:LNDONN)=' '
IF (NMDON2.NE.ERCODE(1:LNDONN)) THEN
Nom de donnee 2 dans la liste des arguments
NUDON2=KELCHN (NMDON2,AST(MCMDON),NBDONN,NCHDON) !sdexplo
IF (NUDON2.LE.0) CALL ERDONN (1,NMDON2) !utilite
CALL SDEXCO (NUDON2,IST(MCDONN),ITYDO2,NIVDO2,ITYPD2) !utilite
IF (ITYDO2.NE.INTDON ('CONSTANTE')) CALL ERDONN (2,NMDON2) !utilite
ENDIF
TYDON2=' '
IF (NUDON2.GT.0) THEN
CALL SDEXCO (NUDON2,IST(MCDONN),ITYDO2,NIVDO2,ITYPD2) !utilite
IF (ITYDO2.EQ.INTDON ('CONSTANTE')) THEN
TYDON2=TYPINT(ITYPD2) !utilite
ELSE
NUDON2=0
ENDIF
ENDIF
Type du terme resultat
TYTRM3=TYTRM1
IF (TYTRM2(1:2).EQ.'CO') TYTRM3=TYTRM2
IF (TYDON1(1:2).EQ.'CO') TYTRM3=TYDON1
IF (TYDON2(1:2).EQ.'CO') TYTRM3=TYDON2
LGTRM3= MIN (LGTRM1,LGTRM2)
ITTRM3= INTTYP (TYTRM3) !utilite
CRETRM=.FALSE.
IF (.NOT.IDMTR2) THEN
IF (.NOT.IDMTR1) THEN
Creation (si necessaire) du vecteur resultat
ITYCA3= INTYKL ('ASSEMB') !utilite
NUKAL3=-INDASS (' ') !utilite
IF (LGTRM1.LE.LGTRM2) THEN
CALL CRTERM (NMTRM3,NVTRM3,LGTRM3,ITTRM3,ITYCA3,NUKAL3
& ,NDFDON,ITYSY1,NVDSM1,NUINC1,NVDUC1,NBNEC1
& ,NVNUC1,NUINL1,NVDUL1,NBNEL1,NVNUL1,INDST1
& ,NVNUS1,NVCOO1,IATRD1,NIVIMP,IDMTR1,CRETRM) !sdexplo
ELSE
CALL CRTERM (NMTRM3,NVTRM3,LGTRM3,ITTRM3,ITYCA3,NUKAL3
& ,NDFDON,ITYSY2,NVDSM2,NUINC2,NVDUC2,NBNEC2
& ,NVNUC2,NUINL2,NVDUL2,NBNEL2,NVNUL2,INDST2
& ,NVNUS2,NVCOO2,IATRD2,NIVIMP,IDMTR2,CRETRM) !sdexplo
ENDIF
ELSE
Le Terme resultat coincide avec le premier terme
IF (ITTRM1.NE.ITTRM3) CALL ERTERM (3,NMTRM1,NVTRM1) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTER1-1)
CALL PUTTRM (IST(IADTRM),NVTRM3,ITTRM3,ITYCA1,NUKAL1,NDFDON
& ,ITYSY1,NVDSM1,NUINC1,NVDUC1,NBNEC1,NVNUC1
& ,NUINL1,NVDUL1,NBNEL1,NVNUL1,INDST1,NVNUS1
& ,NVCOO1,IATRD1,NIVIMP) !sdexplo
ENDIF
ELSE
Le Terme resultat coincide avec le second
IF (ITTRM2.NE.ITTRM3) CALL ERTERM (3,NMTRM1,NVTRM1) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTER2-1)
CALL PUTTRM (IST(IADTRM),NVTRM3,ITTRM3,ITYCA2,NUKAL2,NDFDON
& ,ITYSY2,NVDSM2,NUINC2,NVDUC2,NBNEC2,NVNUC2
& ,NUINL2,NVDUL2,NBNEL2,NVNUL2,INDST2,NVNUS2
& ,NVCOO2,IATRD2,NIVIMP) !sdexplo
ENDIF
Adresses des operandes de l'operation
MCCST1=0
IF (TYDON1(1:1).EQ.'R') THEN
CALL TBAR1 (ERCODE,'$RCSTE',1,MCCST1)
ELSEIF (TYDON1(1:1).EQ.'C') THEN
CALL TBAR1 (ERCODE,'$CCSTE',1,MCCST1)
ELSEIF (TYDON1(1:1).EQ.'E') THEN
CALL TBAR1 (ERCODE,'$ECSTE',1,MCCST1)
ENDIF
MCCST2=MCCST1
IF (TYDON2(1:1).NE.TYDON1(1:1)) THEN
IF (TYDON2(1:1).EQ.'R') THEN
CALL TBAR1 (ERCODE,'$RCSTE',1,MCCST2)
ELSEIF (TYDON2(1:1).EQ.'C') THEN
CALL TBAR1 (ERCODE,'$CCSTE',1,MCCST2)
ELSEIF (TYDON2(1:1).EQ.'E') THEN
CALL TBAR1 (ERCODE,'$ECSTE',1,MCCST2)
ENDIF
ENDIF
CALL TBAR2 (ERCODE,NMTRM1,NVTRM1,MCTRM1,NMTRM2,NVTRM2,MCTRM2)
MCTRM3=MCTRM1
IF (IDMTR2) MCTRM3=MCTRM2
IF (.NOT.(IDMTR1.OR.IDMTR2))
& CALL TBAR1 (ERCODE,NMTRM3,NVTRM3,MCTRM3)
Operation effective
IF (IDMTR2) THEN
t2 = a2.t2 (si a2 existe)
IF (NUDON2.GT.0) CALL TEQAT (LGTRM3,TYTRM2,MCTRM2,RST,CST
& ,TYDON2,MCCST2+NIVDO2,IST,RST,CST
& ,TYTRM2,MCTRM2,RST,CST) !utilite
IF (NUDON1.GT.0) THEN
t2 = (a2.)t2 + a1.t1
CALL TPLUAT (LGTRM3,TYTRM2,MCTRM2,RST,CST
& ,TYDON1,MCCST1+NIVDO1,IST,RST,CST
& ,TYTRM1,MCTRM1,RST,CST
& ,TYTRM2,MCTRM2,RST,CST) !utilite
ELSE
t2 = (a2.)t2 + t1
CALL TPLUST (LGTRM3,TYTRM2,MCTRM2,RST,CST
& ,TYTRM1,MCTRM1,RST,CST
& ,TYTRM2,MCTRM2,RST,CST) !utilite
ENDIF
CALL TBSAVE (NMTRM1,NVTRM1)
CALL TBSAVE (NMTRM2,NVTRM2)
ELSE
IF (NUDON1.GT.0) THEN
t3 = a1.t1
CALL TEQAT (LGTRM3,TYTRM1,MCTRM1,RST,CST
& ,TYDON1,MCCST1+NIVDO1,IST,RST,CST
& ,TYTRM3,MCTRM3,RST,CST) !utilite
ELSEIF (.NOT.IDMTR1) THEN
t3 = t1
CALL TDANST (LGTRM3,TYTRM1,MCTRM1,IST,RST,CST
& ,TYTRM3,MCTRM3,IST,RST,CST) !utilite
ENDIF
IF (NUDON2.GT.0) THEN
t3 = t3 + a2.t2 = (a1.)t1 + a2.t2
CALL TPLUAT (LGTRM3,TYTRM3,MCTRM3,RST,CST
& ,TYDON2,MCCST2+NIVDO2,IST,RST,CST
& ,TYTRM2,MCTRM2,RST,CST
& ,TYTRM3,MCTRM3,RST,CST) !utilite
ELSE
t3 = t3 + t2 = (a1.)t1 + t2
CALL TPLUST (LGTRM3,TYTRM3,MCTRM3,RST,CST
& ,TYTRM2,MCTRM2,RST,CST
& ,TYTRM3,MCTRM3,RST,CST) !utilite
ENDIF
CALL TBSAVE (NMTRM1,NVTRM1)
CALL TBSAVE (NMTRM2,NVTRM2)
IF (.NOT.IDMTR1) CALL TBSAVE (NMTRM3,NVTRM3)
ENDIF
IF (NIVIMP.GE.0.AND.IMPSDR.GT.0) THEN
CALL PRNTRM (NMTRM1,NVTRM1,ERCODE(1:),NCATR1)
CALL PRNTRM (NMTRM2,NVTRM2,ERCODE(NCATR1+1:),NCATR2)
WRITE (IMPSDR,10010) ERCODE(1:NCATR1)
& ,ERCODE(NCATR1+1:NCATR1+NCATR2)
ENDIF
ENDIF
CALL PRFXMJ (-1,'*ClTerm*')
10000 FORMAT(/T2,'*ClTerm* Terme ',A)
10010 FORMAT(T11,'combinaison lineaire des termes ',A,' et ',A)
END !ClTerm
clterm est appelé dans (5 procédures)