[updated 8.Sep.2008]
Librairie assembl > Fichier psterm.f |
SUBROUTINE PSTERM (SOUH,NMTRM1,NVTRM1,NMTRM2,NVTRM2,CESULT,NIVIMP)
Auteur : O.DeBayser (Avril 1993)
Derniere modification : D.Martin (25 Juin 1997)
Version 1.0.0
Produit scalaire ou hermitien entre deux termes vectoriels quelconques
ATTENTION, Le Resultat est TOUJOURS COMPLEXE
-- Arguments d'entree --
SOUH SOUH(1:1)='S' pour produit scalaire, 'H' pour produit hermitien
NMTRM1 nom du 1er vecteur
NVTRM1 niveau du 1er vecteur
NMTRM1 nom du 2nd vecteur
NVTRM1 niveau du 2nd vecteur
CESULT resultat TOUJOURS complexe
NIVIMP niveau d'impression
CHARACTER*(*) SOUH,NMTRM1,NMTRM2
INTEGER NVTRM1,NVTRM2,NIVIMP
COMPLEX CESULT
INCLUDE 'CONTEX'
INCLUDE 'ALLOC'
CHARACTER*4 TYPINT !utilite
INTEGER KLNIVE,KLTERM !utilite
INTEGER MCMTRM,MCDTRM,MCINCO,LGETRM,NBTERM,INCTRM,NCHTRM
& ,NUTERM,IADTRM,NIVEAU,ITYPTR,ITYCAL,NUKALE,NUDONN
& ,ITYSYM,IPTDIR,NUINCC,NVDUCR,NBNECR,NVNUCR
& ,NUINC1,NVDUL1,NBNET1,NVNUL1,INDSTK,NVNUSR,NVCOOR
& ,IATRDO,NIVIMR,NCPIN1,INTERP,NBTNE1
& ,NUINC2,NVDUL2,NBNET2,NVNUL2,NCPIN2,NBTNE2
& ,MCTRM1,MCTRM2,MCNUL1,MCNUL2,NUDEB,NUFIN,NBNINX
& ,LGREEL,MCNEIN,NBNEIN,ITEMD1,ITEMD2,NUNEIN,NUGLO
& ,INET1,INET2
COMPLEX VALEU1,VALEU2
CHARACTER*4 ERCODE*120,TYTRM1,TYTRM2
COMMON/FORMAH/ERCODE
EQUIVALENCE (ERCODE(89:89),TYTRM1),(ERCODE(105:105),TYTRM2)
CALL PRFXMJ (1,'*PsTerm*')
CALL TBAR3 (ERCODE,'#OMTRM',1,MCMTRM
& ,'$SDTRM',1,MCDTRM,'#NCONU',1,MCINCO)
CALL SDEXDB (IST(MCDTRM),LGETRM,NBTERM,INCTRM,NCHTRM) !utilite
Recherche des caracteristiques du 1er vecteur
NUTERM=KLTERM (NMTRM1,NVTRM1,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTERM.LE.0) CALL ERTERM (1,NMTRM1,NVTRM1) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTERM-1)
CALL GETTRM (IST(IADTRM) ,NIVEAU,ITYPTR,ITYCAL,NUKALE,NUDONN
& ,ITYSYM,IPTDIR,NUINCC,NVDUCR,NBNECR,NVNUCR,NUINC1
& ,NVDUL1,NBNET1,NVNUL1,INDSTK,NVNUSR,NVCOOR,IATRDO
& ,NIVIMR) !sdexplo
TYTRM1=TYPINT (ITYPTR)
IF (NUINC1.NE.NDFINC) THEN
CALL SDEXCO (NUINC1,IST(MCINCO),NCPIN1,INTERP,NBTNE1) !utilite
ELSE
CALL SDEXCO (NUINCC,IST(MCINCO),NCPIN1,INTERP,NBTNE1) !utilite
ENDIF
Faut-il les numerotations en d.l.
IF (NCPIN1.GT.1) THEN
IF (NUINC1.EQ.NDFINC.AND.NVDUCR.EQ.NDFDUM) THEN
NVDUCR=KLNIVE ()
ELSEIF (NVDUL1.EQ.NDFDUM) THEN
NVDUL1=KLNIVE ()
ENDIF
CALL PUTTRM (IST(IADTRM),NIVEAU,ITYPTR,ITYCAL,NUKALE,NUDONN
& ,ITYSYM,IPTDIR,NUINCC,NVDUCR,NBNECR,NVNUCR,NUINC1
& ,NVDUL1,NBNET1,NVNUL1,INDSTK,NVNUSR,NVCOOR,IATRDO
& ,NIVIMR) !sdexplo
ENDIF
IF (NUINC1.EQ.NDFINC) THEN
NVNUL1=NVNUCR
NVDUL1=NVDUCR
NUINC1=NUINCC
NBNET1=NBNECR
ENDIF
NBNET1=NBNET1*NCPIN1
Recherche des caracteristiques du 2eme vecteur
NUTERM=KLTERM (NMTRM2,NVTRM2,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTERM.LE.0) CALL ERTERM (1,NMTRM2,NVTRM2) !utilite
IADTRM=MCDTRM+LGETRM+INCTRM*(NUTERM-1)
CALL GETTRM (IST(IADTRM) ,NIVEAU,ITYPTR,ITYCAL,NUKALE,NUDONN
& ,ITYSYM,IPTDIR,NUINCC,NVDUCR,NBNECR,NVNUCR,NUINC2
& ,NVDUL2,NBNET2,NVNUL2,INDSTK,NVNUSR,NVCOOR,IATRDO
& ,NIVIMR) !sdexplo
TYTRM2=TYPINT (ITYPTR)
IF (NUINC2.NE.NDFINC) THEN
CALL SDEXCO (NUINC2,IST(MCINCO),NCPIN2,INTERP,NBTNE2) !utilite
ELSE
CALL SDEXCO (NUINCC,IST(MCINCO),NCPIN2,INTERP,NBTNE2) !utilite
ENDIF
Faut-il les numerotations en d.l.
IF (NCPIN2.GT.1) THEN
IF (NUINC2.EQ.NDFINC.AND.NVDUCR.EQ.NDFDUM) THEN
NVDUCR=KLNIVE ()
ELSEIF (NVDUL2.EQ.NDFDUM) THEN
NVDUL2=KLNIVE ()
ENDIF
CALL PUTTRM (IST(IADTRM),NIVEAU,ITYPTR,ITYCAL,NUKALE,NUDONN
& ,ITYSYM,IPTDIR,NUINCC,NVDUCR,NBNECR,NVNUCR,NUINC2
& ,NVDUL2,NBNET2,NVNUL2,INDSTK,NVNUSR,NVCOOR,IATRDO
& ,NIVIMR) !sdexplo
ENDIF
IF (NUINC2.EQ.NDFINC) THEN
NVNUL2=NVNUCR
NVDUL2=NVDUCR
NUINC2=NUINCC
NBNET2=NBNECR
ENDIF
NBNET2=NBNET2*NCPIN2
IF (NCPIN1.NE.NCPIN2) CALL BAISE (' Inconnues incoherentes') !utilite
-- Le cas echeant transformation des numerotations en d.l.
IF (NCPIN1.GT.1) THEN
CALL NUM2DL (NCPIN1,NVNUL1,NVDUL1,NBNET1,NIVIMP) !sdexplo
NVNUL1=NVDUL1
ENDIF
IF (NCPIN2.GT.1) THEN
CALL NUM2DL (NCPIN2,NVNUL2,NVDUL2,NBNET2,NIVIMP) !sdexplo
NVNUL2=NVDUL2
ENDIF
Si l'une des numerotations est incluse dans l'autre ...
CALL TBRR4 (ERCODE, NMTRM1 ,NVTRM1,MCTRM1, NMTRM2 ,NVTRM2,MCTRM2
& ,'#GNEDO',NVNUL1,MCNUL1,'#GNEDO',NVNUL2,MCNUL2)
CALL TBAR2 (ERCODE,'#GNEDO',NVNUL1,MCNUL1,'#GNEDO',NVNUL2,MCNUL2)
CALL LISINC (NBNET1,IST(MCNUL1+2),NBNET2,IST(MCNUL2+2)
& ,NUDEB,NUFIN,*9) !utilite
GOTO 10
Si l'une des numerotations est une partie de noeuds consecutifs
de l'autre, le calcul est direct
9 IF (NUFIN-NUDEB+1.EQ.NBNET1) THEN
Calcul direct si les numerotations se correspondent
CALL TBAR2 (ERCODE,NMTRM2,NVTRM2,MCTRM2,NMTRM1,NVTRM1,MCTRM1)
IF (SOUH(1:1).EQ.'S') THEN
CALL TSCALT (NBNET1,TYTRM1(1:1),MCTRM1,RST,CST
& ,TYTRM2(1:1),MCTRM2,RST,CST,CESULT) !utilite
ELSEIF (SOUH(1:1).EQ.'H') THEN
CALL THERMT (NBNET1,TYTRM1(1:1),MCTRM1,RST,CST
& ,TYTRM2(1:1),MCTRM2,RST,CST,CESULT) !utilite
ENDIF
GOTO 300
ENDIF
10 NBNINX=MIN (NBNET1,NBNET2)
CALL TBCRSU ('#GNEDO',0,1,NBNINX,LGREEL,'c')
NBNINX=LGREEL
CALL TBAR5 (ERCODE,'#GNEDO',NVNUL1,MCNUL1,'#GNEDO',NVNUL2,MCNUL2
& ,'#GNEDO',0,MCNEIN
& , NMTRM2 ,NVTRM2,MCTRM2, NMTRM1 ,NVTRM1,MCTRM1)
MCNUL1=MCNUL1+2
MCTRM1=MCTRM1-1
MCNUL2=MCNUL2+2
MCTRM2=MCTRM2-1
Calcul de la numerotation de l'intersection
CALL LISINT (NBNET1,IST(MCNUL1),NBNET2,IST(MCNUL2),NBNEIN
& ,IST(MCNEIN),NBNINX,*20) !utilite
Boucle sur les noeuds de l'intersection
20 CESULT=0.
ITEMD1=1
ITEMD2=1
DO 100 NUNEIN=1,NBNEIN
NUGLO=IST(MCNEIN+NUNEIN-1)
CALL DICOTO (ITEMD1,NBNET1,IST(MCNUL1),NUGLO,INET1,*100) !utilite
ITEMD1=INET1+1
CALL DICOTO (ITEMD2,NBNET2,IST(MCNUL2),NUGLO,INET2,*100) !utilite
ITEMD2=INET2+1
IF (TYTRM1(1:1).EQ.'R') THEN
VALEU1=RST(MCTRM1+INET1)
ELSE
VALEU1=CST(MCTRM1+INET1)
ENDIF
IF (TYTRM2(1:1).EQ.'R') THEN
VALEU2=RST(MCTRM2+INET2)
ELSE
VALEU2=CST(MCTRM2+INET2)
ENDIF
Calcul du produit
IF (SOUH(1:1).EQ.'S') THEN
CESULT=CESULT + VALEU1*VALEU2
ELSEIF (SOUH(1:1).EQ.'H') THEN
CESULT=CESULT + VALEU1*CONJG(VALEU2)
ENDIF
100 CONTINUE
CALL TBTUER ('#GNEDO',0)
300 CALL TBSAVE ('#GNEDO',NVNUL1)
IF (NVNUL1.NE.NVNUL2) CALL TBSAVE ('#GNEDO',NVNUL2)
CALL TBSAVE (NMTRM1,NVTRM1)
CALL TBSAVE (NMTRM2,NVTRM2)
CALL PRFXMJ (-1,'*PsTerm*')
END !Psterm
psterm est appelé dans (4 procédures)