[updated 30.Oct.2008]
Librairie assembl > Fichier asmtrm.f |
SUBROUTINE ASMTRM (NMTERM,NVTERM,NIVIMP)
Auteur : D.Martin (Janvier 1990)
Derniere modification : D.Martin (30 octobre 2008)
Version 2
Assemblage uni-inconnue du terme matriciel NMTERM de niveau NVTERM
selon sa structure d'assemblage $ASMBL
-- Arguments d'entree --
NMTERM nom du terme resultat de l'assemblage
NVTERM niveau du terme resultat de l'assemblage
NIVIMP niveau d'impression du terme
si l'assemblage a ete declaree par directive, le niveau d'impression
est celui declare par directive, ou sa valeur par defaut
IMPLICIT NONE
CHARACTER*(*) NMTERM
INTEGER NVTERM,NIVIMP
INCLUDE 'ALLOC'
INCLUDE 'CONTEX'
CHARACTER TYPINT*9,STODLN*6,STOIND*7,SYMIND*14
CHARACTER ERCODE*120,PRFXAS*8
CHARACTER CHANGD,CHANGC,CHANGL,IDMSTK,IDMBMS,CRWORK,OPERAT
CHARACTER THETR1*16,THETR2*16,CHCSTE*6,NMSTOK*6,NMSTOD*6
INTEGER INDASS,INDSTO,INDSYM,INTYKL,KLNIVE,KLTERM
INTEGER INUTI1,INUTI2,ESTPLA,NCATR1,NCATR2,NIVEAU,IRCODE
& ,MCMTRM,MCDTRM,LGETRM,NBTERM,INCTRM,NCHTRM,NUTERM
& ,ITYPTR,ITYCAL,NUKALE,NUDONN,ITYSYM,NVASMB,NUINCC
& ,NVDUMC,NBNECO,NVNUMC,NUINCL,NVDUML,NBNELI,NVNUML
& ,INSTOK,NVSTOK,NVCOOR,IATRDO,NIVTMR,NIVREL,MCASMB
& ,MCINCO,NCPINC,INTRPC,NCPINL,INTRPL
& ,MCSTOK,NBPLAL,MCPLAL,MCPLIL,LGL,NBPLAU,MCPLAU
& ,MCPLIU,LGU,NBPLAG,NVNUC1,NVNUL1,NVSTO1,LGCREE
& ,MCNUMC,MCNUML,LGSTOK,NBPLAX,NEMOIN,MCTERM,LGTERM
COMMON/FORMAH/ERCODE
EQUIVALENCE (ERCODE(73:73),THETR2),(ERCODE(89:89),THETR1)
& ,(ERCODE(105:105),CHCSTE),(ERCODE(113:113),NMSTOK)
& ,(ERCODE(119:119),CRWORK),(ERCODE(120:120),OPERAT)
>>> Attention dans cette procedure et celles qu'elle appelle
>>> on utilise le common FORMAH pour transporter des info
CALL PRFXMJ (1,'*AsmTrm*')
CALL TBAR2 (ERCODE,'#OMTRM',1,MCMTRM,'$SDTRM',1,MCDTRM)
CALL SDEXDB (IST(MCDTRM),LGETRM,NBTERM,INCTRM,NCHTRM) !utilite
NUTERM=KLTERM (NMTERM,NVTERM,AST(MCMTRM),IST(MCDTRM)) !sdexplo
IF (NUTERM.LE.0) CALL ERTERM (1,NMTERM,NVTERM) !utilite
CALL GETTRM (IST(MCDTRM+LGETRM+INCTRM*(NUTERM-1)),NIVEAU,ITYPTR
& ,ITYCAL,NUKALE,NUDONN,ITYSYM,NVASMB,NUINCC,NVDUMC
& ,NBNECO,NVNUMC,NUINCL,NVDUML,NBNELI,NVNUML,INSTOK
& ,NVSTOK,NVCOOR,IATRDO,NIVTMR) !sdexplo
Le niveau d'impression par directive est prioritaire s'il est non nul
NIVREL=NIVIMP
IF (NIVTMR.NE.0) NIVREL=NIVTMR
IF (ITYCAL.NE.INTYKL('ASSEMB').OR.ABS(NUKALE).NE.INDASS (' ')) !utilite
& CALL ERTERM (13,NMTERM,NVTERM) !utilite
IF (NIVREL.GT.0.AND.IMPSDR.GT.0) THEN
CALL PRNTRM (NMTERM,NVTERM,THETR1,NCATR1) !utilite
WRITE (IMPSDR,10000) PRFXAS (0),THETR1(1:NCATR1),SYMIND(ITYSYM)
ENDIF
CALL TBRR1 (ERCODE,'$ASMBL',NVASMB,MCASMB)
IF (NUKALE.LT.0) THEN
Si la structure d'assemblage n'a pas ete remise a jour,
on passe directement a l'assemblage proprement dit
CALL TBAR1 (ERCODE,'#NCONU',1,MCINCO)
CALL SDEXCO (NUINCC,IST(MCINCO),NCPINC,INTRPC,INUTI1) !utilite
NCPINL=NCPINC
IF (NUINCL.NE.NUINCC)
& CALL SDEXCO (NUINCL,IST(MCINCO),NCPINL,INTRPL,INUTI2) !utilite
IF (INSTOK.EQ.INDSTO ('BIMORSE')) THEN !utilite
NMSTOK='&BMORS'
CALL TBRR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL EXBMOR (MCSTOK,IST(MCSTOK)
& ,NBNELI,NBPLAL,MCPLAL,MCPLIL,LGL
& ,NBNECO,NBPLAU,MCPLAU,MCPLIU,LGU) !utilite
LGTERM=MIN (NBNELI,NBNECO)+LGL
IF (ITYSYM.EQ.NDFSYM) LGTERM=LGTERM+LGU
ELSE
IF (INSTOK.EQ.INDSTO ('MORSE-L')) THEN !utilite
NMSTOK='&PLAGE'
ELSEIF (INSTOK.EQ.INDSTO ('MORSE-C')) THEN !utilite
NMSTOK='&EGALP'
ENDIF
CALL TBRR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL EXMORS (MCSTOK,IST(MCSTOK)
& ,NBNELI,NBNECO,NBPLAG,MCPLAL,MCPLIL,LGTERM) !utilite
ENDIF
ELSE
NIVEAU=0
Determination de l'ordre de parcours de la structure et
des niveaux des tableaux de numerotation du terme resultat
>>>>>>>Ne pas modifier la valeur 1 de l'argument 3 ci-dessous
IF (NIVREL.GT.5) CALL PRSDAS (NVASMB,NUTERM,1,IMPSDR) !prsd
IRCODE=0
CALL ASMNIV (NMTERM,NVTERM,NUTERM,NVASMB,ITYPTR,NUINCC,NVDUMC
& ,NBNECO,NVNUMC,NCPINC,NUINCL,NVDUML,NBNELI,NVNUML
& ,NCPINL,ITYSYM,INSTOK,NVSTOK,NVCOOR,IATRDO
& ,NVNUC1,NVNUL1,NVSTO1,IDMSTK,IDMBMS,IRCODE) !assembl
IF (IRCODE.EQ.-1) THEN
CALL WARNNG ('Assemblage symetrique demande pour un terme'
& //' qui ne l''est pas.')
ENDIF
CALL TBAR2 (ERCODE,'$SDTRM',1,MCDTRM,'$ASMBL',NVASMB,MCASMB)
CALL ASMORD (IST(MCASMB),IST(MCDTRM)) !assembl
IF (NIVREL.GT.0) CALL PRSDAS (NVASMB,NUTERM,NIVREL,IMPSDR) !prsd
Numerotation des noeuds du terme pour l'interpolation en colonne
CHANGC='N'
IF (NVNUMC.EQ.NDFNUM) THEN
CHANGD='Y'
IF (NIVEAU.EQ.0) NIVEAU=KLNIVE () !sdexplo
NVNUMC=NIVEAU
CALL TBCRSU ('#GNEDO',NVNUMC,1,2+NBNECO,LGCREE,'c')
NBNECO=LGCREE-2
CALL ASNUME (NVASMB,'Colonne',NVNUMC,NBNECO,CHANGD,IRCODE) !assembl
IF (IRCODE.EQ.1) GOTO 99991
IF (CHANGD.EQ.'Y') THEN
CHANGC=CHANGD
IF (NIVREL.GE.3) THEN
CALL TBAR1 (ERCODE,'#GNEDO',NVNUMC,MCNUMC)
CALL PRNEDO ('*AsmTrm*','Colonne',IST(MCNUMC),IMPSDR) !prsd
ENDIF
CALL TBAJST ('#GNEDO',NVNUMC,2+NBNECO)
ENDIF
ENDIF
Numerotation des noeuds du terme pour l'interpolation en ligne
CHANGL='N'
IF (NVNUML.EQ.NDFNUM) THEN
CHANGD='Y'
NVNUML=KLNIVE () !sdexplo
IF (NIVEAU.EQ.1) NIVEAU=NVNUML
CALL TBCRSU ('#GNEDO',NVNUML,1,2+NBNELI,LGCREE,'c')
NBNELI=LGCREE-2
CALL ASNUME (NVASMB,'Ligne',NVNUML,NBNELI,CHANGD,IRCODE) !assembl
IF (IRCODE.EQ.1) GOTO 99992
IF (CHANGD.EQ.'Y') THEN
CHANGL=CHANGD
IF (NIVREL.GE.3) THEN
CALL TBAR1 (ERCODE,'#GNEDO',NVNUML,MCNUML)
CALL PRNEDO ('*AsmTrm*','Ligne',IST(MCNUML),IMPSDR) !prsd
ENDIF
CALL TBAJST ('#GNEDO',NVNUML,2+NBNELI)
ENDIF
ENDIF
Les numerotations eventuelement nouvelles rendent-elles necessaires
la confection de compactage
IF (NVSTOK.EQ.NDFSTO.AND.NVNUMC.EQ.NVNUC1.AND.NVNUML.EQ.NVNUL1
& .AND.IDMSTK.EQ.'Y'.AND.IDMBMS.EQ.'Y') NVSTOK=NVSTO1
IF (NVSTOK.EQ.NDFSTO) THEN
Calcul des tables de stockage correspondantes
CALL ASMTAY (NVASMB,ESTPLA) !assembl
ESTPLA=ESTPLA/(NCPINC*NCPINL)
IF (NIVEAU.EQ.0) NIVEAU=KLNIVE () !sdexplo
NVSTOK=NIVEAU
IF (NBNECO.LE.0) THEN
CALL TBAR1 (ERCODE,'#GNEDO',NVNUMC,MCNUMC)
NBNECO=IST(MCNUMC+1)
ENDIF
IF (NBNELI.LE.0) THEN
CALL TBAR1 (ERCODE,'#GNEDO',NVNUML,MCNUML)
NBNELI=IST(MCNUML+1)
ENDIF
CHANGD='Y'
Restauration des tableaux de numerotations ligne/colonne
histoire de leur reserver de la place avant la saturation
eventuelle par TBCRSU
CALL TBRR2 (ERCODE,'#GNEDO',NVNUC1,INUTI1
& ,'#GNEDO',NVNUL1,INUTI2)
IF (NMSTOK.EQ.'&BMORS') THEN
LGSTOK=2*(1+NBNELI)+4*ESTPLA
IF (ITYSYM.NE.NDFSYM) LGSTOK=LGSTOK/2
CALL TBCRSU (NMSTOK,NVSTOK,1,LGSTOK,LGCREE,'c')
NBPLAX=(LGCREE-1-NBNELI)/2
IF (ITYSYM.EQ.NDFSYM) NBPLAX=(LGCREE-3-NBNELI-NBNECO)/2
CALL ASMSTB (NVASMB,NBPLAX,ITYSYM,NVNUML,NBNELI,NVNUMC
& ,NBNECO,NMSTOK,NVSTOK,LGSTOK,LGTERM) !assembl
IF (CHANGD.EQ.'Y') THEN
IF (NIVREL.GE.5) THEN
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL PRBMOR (IST(MCSTOK),' Terme'
& ,NMTERM,NVTERM,NIVREL,IMPSDR) !prsd
ENDIF
CALL TBAJST (NMSTOK,NVSTOK,LGSTOK)
ENDIF
ELSEIF (NMSTOK.EQ.'&PLAGE') THEN
LGSTOK=MIN(NBNELI*(NBNECO+1),4+NBNELI+2*ESTPLA)
CALL TBCRSU (NMSTOK,NVSTOK,1,LGSTOK,LGCREE,'c')
NBPLAX=(LGCREE-4-NBNELI)/2
CALL ASMSTM (NVASMB,NBPLAX,NVNUML,NBNELI,NVNUMC,NBNECO
& ,NMSTOK,NVSTOK,LGSTOK,LGTERM) !assembl
IF (CHANGD.EQ.'Y') THEN
IF (NIVREL.GE.5) THEN
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL PRMORS (IST(MCSTOK),'L',' Terme'
& ,NMTERM,NVTERM,NIVREL,IMPSDR) !prsd
ENDIF
CALL TBAJST (NMSTOK,NVSTOK,LGSTOK)
ENDIF
ELSEIF (NMSTOK.EQ.'&EGALP') THEN
LGSTOK=MIN(NBNECO*(NBNELI+1),4+NBNECO+2*ESTPLA)
CALL TBCRSU (NMSTOK,NVSTOK,1,LGSTOK,LGCREE,'c')
NBPLAX=(LGCREE-4-NBNECO)/2
CALL ASMSTM (NVASMB,NBPLAX,NVNUMC,NBNECO,NVNUML,NBNELI
& ,NMSTOK,NVSTOK,LGSTOK,LGTERM) !assembl
IF (CHANGD.EQ.'Y') THEN
IF (NIVREL.GE.5) THEN
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL PRMORS (IST(MCSTOK),'C',' Terme'
& ,NMTERM,NVTERM,NIVREL,IMPSDR) !prsd
ENDIF
CALL TBAJST(NMSTOK,NVSTOK,LGSTOK)
ENDIF
ENDIF
ELSE
Les tables de stockage existent
IF (NMSTOK.EQ.'&BMORS') THEN
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL EXBMOR (MCSTOK,IST(MCSTOK)
& ,NBNELI,NBPLAL,MCPLAL,MCPLIL,LGL
& ,NBNECO,NBPLAU,MCPLAU,MCPLIU,LGU) !utilite
LGTERM=MIN (NBNELI,NBNECO)+LGL
IF (ITYSYM.EQ.NDFSYM) LGTERM=LGTERM+LGU
ELSE
CALL TBAR1 (ERCODE,NMSTOK,NVSTOK,MCSTOK)
CALL EXMORS (MCSTOK,IST(MCSTOK)
& ,NBNELI,NBNECO,NBPLAG,MCPLAL,MCPLIL,LGTERM) !utilite
ENDIF
ENDIF
ENDIF
IF (NCPINL*NCPINC.GT.1) THEN
IF (NMSTOK.EQ.'&BMORS') THEN
NMSTOD = STODLN(INSTOK,NCPINC,NCPINL) !utilite
CALL BMO2DL (NVSTOK,NCPINL,NCPINC,ITYSYM,NMTERM,NVTERM
& ,NIVREL) !sdexplo
CALL TBSAVE (NMSTOD,NVSTOK)
ELSEIF (NMSTOK.EQ.'&PLAGE') THEN
NMSTOD = STODLN(INSTOK,NCPINC,NCPINL) !utilite
CALL MOL2DL (NVSTOK,NCPINL,NCPINC,NMTERM,NVTERM,NIVREL) !sdexplo
CALL TBSAVE (NMSTOD,NVSTOK)
ELSEIF (NMSTOK.EQ.'&EGALP') THEN
NMSTOD = STODLN(INSTOK,NCPINC,NCPINL) !utilite
CALL MOC2DL (NVSTOK,NCPINL,NCPINC,NMTERM,NVTERM,NIVREL) !sdexplo
CALL TBSAVE (NMSTOD,NVSTOK)
ENDIF
ENDIF
Assemblage proprement dit du terme
NEMOIN=0
IF (ITYSYM.EQ.INDSYM ('SYMETRIQUE')) !utilite
& NEMOIN=MIN(NBNELI,NBNECO)*NCPINC*(NCPINC-1)/2
LGTERM=NCPINC*NCPINL*LGTERM-NEMOIN
CALL TBCREE (NMTERM,NVTERM,ITYPTR,LGTERM,'c')
Mise a zero du terme avant assemblage
CALL TBAR1 (ERCODE,NMTERM,NVTERM,MCTERM)
CALL TAZERO (LGTERM,TYPINT(ITYPTR),MCTERM,AST,IST,RST,CST) !utilite
CALL ASMATR (NMTERM,NVTERM,TYPINT(ITYPTR),NVASMB,NCPINC,NVNUMC
& ,NBNECO,NCPINL,NVNUML,NBNELI,NVSTOK,ITYSYM
& ,NIVREL,IMPSDR) !assembl
Mise a jour des attributs du terme assemble dans $SDTRM
CALL TBAR1 (ERCODE,'$SDTRM',1,MCDTRM)
ITYCAL= INTYKL ('ASSEMB') !utilite
NUKALE=-INDASS (' ') !utilite
CALL PUTTRM (IST(MCDTRM+LGETRM+INCTRM*(NUTERM-1)),NVTERM,ITYPTR
& ,ITYCAL,NUKALE,NUDONN,ITYSYM,NVASMB,NUINCC
& ,NVDUMC,NBNECO,NVNUMC,NUINCL,NVDUML,NBNELI,NVNUML
& ,INSTOK,NVSTOK,NVCOOR,IATRDO,NIVREL) !sdexplo
IF (NIVREL.GT.0) CALL PRTERM (NMTERM,NVTERM,NIVREL,IMPSDR) !prsd
CALL TBSAVE ( NMTERM ,NVTERM)
CALL TBSAVE ('$ASMBL',NVASMB)
IF (NIVREL.GE.0.AND.IMPPAL.GT.0) THEN
CALL PRNTRM (NMTERM,NVTERM,THETR1,NCATR1) !utilite
IF (ITYSYM.EQ.0) THEN
WRITE (IMPPAL,10000) PRFXAS (0),THETR1(1:NCATR1)
& ,TYPINT(ITYPTR),STOIND(INSTOK)
ELSE
WRITE (IMPPAL,10000) PRFXAS (0),THETR1(1:NCATR1)
& ,TYPINT(ITYPTR),STOIND(INSTOK)
& ,SYMIND(ITYSYM)
ENDIF
ENDIF
CALL PRFXMJ (-1,'*AsmTrm*')
RETURN
10000 FORMAT(/T2,A8,' Assemblage du terme ',A,', ',A,', ',A,:,', ',A)
99991 CALL ENCLER (NBNECO,ERCODE(1:6))
CALL PRNTRM (NMTERM,NVTERM,THETR1,NCATR1)
CALL PRNTRM ('#GNEDO',NVNUMC,THETR2,NCATR2)
CALL BAISE ('Taille sous-estimee ('//ERCODE(1:6)
&//') pour la numerotation en colonne '//THETR2(1:NCATR2)
&//' lors de l''assemblage du terme '//THETR1(1:NCATR1))
99992 CALL PRNTRM (NMTERM,NVTERM,THETR1,NCATR1)
CALL ENCLER (NBNELI,ERCODE(1:6))
CALL PRNTRM ('#GNEDO',NVNUML,THETR2,NCATR2)
CALL BAISE ('Taille sous-estimee ('//ERCODE(1:6)
&//') pour la numerotation en ligne '//THETR2(1:NCATR2)
&//' lors de l''assemblage du terme '//THETR1(1:NCATR1))
-- File history
Version 2 : D.Martin (30 octobre 2008)
Changement de nom des structures en DL (appel de STODLN)
Version 1.5 D.Martin (19 Septembre 2003)
END
asmtrm est appelé dans (19 procédures)