C PRASE3 SOURCE GOUNAND 22/08/25 21:15:08 11434 SUBROUTINE PRASE3(MATELE,MRENU,MMULAG,METASS, $ KTIME,LTIME, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : PRASE3 C PROJET : Noyau linéaire NLIN C DESCRIPTION : On effectue l'assemblage d'un ensemble de matrices C élémentaires pour faire une matrice Morse. C C C Quelques commentaires sur la numérotation pour le placement des C multiplicateurs de Lagrange : C C * Au niveau des noms d'inconnues : C 1) Placement juste après un nom sur lequel porte la relation C 2) Placement après tous les noms sur lesquels porte la relation C * Au niveau des ddls : C a) Placement après tous les ddls sur lesquels porte la relation C b) Placement par points si le multiplicateur de Lagrange C est dans un espace d'éléments finis C 'APR2' = 1a ; 'APR3' = 1b ; 'APR4' = 2a ; 'APR5' = 2b C C C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : FIXMEL, MLUNIQ, MKMPOS, MKNPOS, MAKPRM, MAKPMT C FUSPRM C APPELES (UTIL.) : FIMOTS, RSETXI, CUNIQ, CREPER, IUNIQ, ISETI C APPELES (STAT.) : INMSTA, PRMSTA C APPELE PAR : KRES2 C*********************************************************************** C ENTREES : MRENU, MMULAG C ENTREES/SORTIES : MATELE C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 24/11/99, nouvelle version initiale C HISTORIQUE : v1, 30/09/99, création C HISTORIQUE : 05/01/00 : modif. appel fixmel C HISTORIQUE : 13/01/00 : Rajout d'une méthode de renumérotation avec C placement des multiplicateurs de Lagrange plus efficace C (cf. subroutine calnu2). C HISTORIQUE : 06/04/04 : Renumerotation C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** * MATASS est une matrice de préconditionnement déjà assemblée * permettant de sauter des étapes de l'assemblage -INC PPARAM -INC CCOPTIO -INC SMCOORD character*(*) mrenu, mmulag -INC SMLENTI INTEGER JG POINTEUR KRSPGT.MLENTI POINTEUR KRSPGD.MLENTI C! POINTEUR KRILAG.MLENTI POINTEUR KRINCP.MLENTI POINTEUR KRINCD.MLENTI POINTEUR KRIPUN.MLENTI POINTEUR KRIDUN.MLENTI POINTEUR NEWNUM.MLENTI POINTEUR IWORK.MLENTI POINTEUR LITYP.MLENTI POINTEUR LINIV.MLENTI POINTEUR LDDLDU.MLENTI POINTEUR LDDLDT.MLENTI -INC SMLMOTS INTEGER JGM,JGN C! POINTEUR GPINCS.MLMOTS C! POINTEUR GPILAG.MLMOTS POINTEUR LITOT.MLMOTS C!*-INC SMLLOGI C! SEGMENT MLLOGI C! LOGICAL LOGI(JG) C! ENDSEGMENT C! POINTEUR LILAG.MLLOGI -INC SMELEME POINTEUR MELPRI.MELEME POINTEUR MELDUA.MELEME POINTEUR MELPR2.MELEME POINTEUR MELDU2.MELEME POINTEUR MLPPRI.MELEME POINTEUR MLPDUA.MELEME POINTEUR KJSPGT.MELEME -INC SMMATRIK POINTEUR MATELE.MATRIK POINTEUR IMATEL.IMATRI INTEGER NBI,NPT POINTEUR KMINCT.MINC INTEGER NTT,NJA POINTEUR PMTOT.PMORS INTEGER NBVA POINTEUR IZATOT.IZA POINTEUR PMTO2.PMORS POINTEUR IZATO2.IZA POINTEUR PMCOU.PMORS POINTEUR PMCO2.PMORS POINTEUR PMCOT.PMORS INTEGER NBLK POINTEUR IDMTOT.IDMAT -INC SMTABLE POINTEUR KTIME.MTABLE DIMENSION ITTIME(4) CHARACTER*8 CHARI LOGICAL LTIME * * Ensemble de profils morse * * * Includes persos * * Segment avec diverses statistiques mémoire et CPU *STAT -INC SMSTAT *STAT POINTEUR MSTOT.MSTAT *STAT POINTEUR MSPRM.MSTAT *STAT POINTEUR MSMAT.MSTAT * Liste de MELEME INTEGER NBMEL SEGMENT MELS POINTEUR LISMEL(NBMEL).MELEME ENDSEGMENT POINTEUR GPMELS.MELS POINTEUR GPMLPP.MELS POINTEUR GPMLPD.MELS * SEGMENT PMORSS POINTEUR LISDD(NBPM).MLENTI POINTEUR LISPM(NBPM).PMORS ENDSEGMENT * INTEGER IMPR,IRET * REAL*8 RDUMMY(1) INTEGER IBI C! INTEGER NBMTOT,NBM,NBM2 INTEGER IMATE INTEGER NMATE INTEGER NPOPRI,NPODUA INTEGER ITTDDL INTEGER NTOGPO,NTOTPO,NTOTIN,NTTDDL INTEGER NNZTOT INTEGER LNM,NME INTEGER NMEUNI INTEGER IPROFI,JOB LOGICAL LASEM,LSYM,LOGII * C C Définition des options C C algorithmes utilisés pour la renumérotation C * 'RIEN' : pas de renumérotation C * 'SLOA' : algorithme de chez Sloan C * 'GIPR' : Gibbs-King (profile reduction) C * 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction) PARAMETER (NRENU=4) CHARACTER*4 LRENU(NRENU) C algorithmes utilisés pour la prise en compte des mult.lag. C! a supprimmer C! * 'ECHA' : on renumérote tout puis on change C! de place les mulag pour les mettre après C! les ddl qui leur correspondent C! * 'APRE' : on renumérote sans les mult.lag. PUIS C! on les place après les ddl qui leur correspondent C! * 'APR2' : on renumérote avec les mult.lag. PUIS on les extrait C! on les replace après les ddl qui leur correspondent C * 'RIEN' : on ne fait rien de particulier pour les C multiplicateurs de lagrange C * 'APR3' : on ne fait rien de particulier pour les C multiplicateurs de lagrange PARAMETER (NMULAG=5) CHARACTER*4 LMULAG(NMULAG) IVALI=0 XVALI=REAL(0.D0) LOGII=.FALSE. IRETI=0 XVALR=REAL(0.D0) IRETR=0 DATA LRENU/'RIEN','SLOA','GIPR','GIBA'/ DATA LMULAG/'RIEN','APR2','APR3','APR4','APR5'/ * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prase3' IF (LTIME) THEN call timespv(ittime,oothrd) ITI1=(ITTIME(1)+ITTIME(2))/10 ENDIF * * Lecture des données (options renumérotation et mult.lag) * CALL FICH4(MRENU,LRENU,NRENU,IRENU,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FICH4(MMULAG,LMULAG,NMULAG,IMULAG,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 *STAT CALL INMSTA(MSTAT,IMPR) *STAT CALL INMSTA(MSTOT,0) * * Quelques tests * SEGACT MATELE NMATE=MATELE.IRIGEL(/2) * WRITE(IOIMP,*) 'NMATE=',NMATE IF (NMATE.LE.0) THEN WRITE(IOIMP,*) 'Pas de matrices élémentaires à assembler' GOTO 9999 ENDIF PMTOT=MATELE.KIDMAT(4) LASEM=(PMTOT.NE.0) IF (LASEM.AND.IMPR.GT.0) THEN WRITE(IOIMP,*) 'Les matrices élémentaires sont déjà assemblées' ENDIF SEGDES MATELE IF (LASEM) GOTO 9998 *STAT CALL PRMSTA(' Après les tests',MSTAT,IMPR) * * Correction des maillages (à supprimmer dès que possible) * SEGACT MATELE*MOD DO 11 IMATE=1,NMATE MELPRI=MATELE.IRIGEL(1,IMATE) MELDUA=MATELE.IRIGEL(2,IMATE) CALL FIXMEL(MELPRI,MELDUA, $ MELPR2,MELDU2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 MATELE.IRIGEL(1,IMATE)=MELPR2 MATELE.IRIGEL(2,IMATE)=MELDU2 11 CONTINUE SEGDES MATELE *STAT CALL PRMSTA(' Après fixmel',MSTAT,IMPR) * * Construire l'ensemble des points primaux et duaux pour chaque * matrice élémentaire (on ne veut plus utiliser les KSPGPs et KSPGDs * des IMATRI). * SEGACT MATELE NBMEL=NMATE SEGINI GPMLPP NBMEL=NMATE SEGINI GPMLPD NBMEL=1 SEGINI GPMELS * In 12 : SEGINI GPMLPP.LISMEL(*) * In 12 : SEGINI GPMLPD.LISMEL(*) DO 12 IMATE=1,NMATE SEGACT GPMELS*MOD GPMELS.LISMEL(1)=MATELE.IRIGEL(1,IMATE) SEGDES GPMELS CALL MLUNIQ(GPMELS,MLPPRI,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 GPMLPP.LISMEL(IMATE)=MLPPRI SEGACT GPMELS*MOD GPMELS.LISMEL(1)=MATELE.IRIGEL(2,IMATE) SEGDES GPMELS CALL MLUNIQ(GPMELS,MLPDUA,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 GPMLPD.LISMEL(IMATE)=MLPDUA 12 CONTINUE SEGSUP GPMELS SEGDES MATELE * * Construire l'ensemble des points sur lesquels sont localisées des * inconnues (KJSPGT). * NBMEL=NMATE*2 SEGINI GPMELS DO 1 IMATE=1,NMATE GPMELS.LISMEL(2*IMATE-1)=GPMLPP.LISMEL(IMATE) GPMELS.LISMEL(2*IMATE) =GPMLPD.LISMEL(IMATE) 1 CONTINUE CALL MLUNIQ(GPMELS,KJSPGT,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP GPMELS IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'L''ensemble des points est :' SEGPRT,KJSPGT ENDIF * Construire la liste de correspondance pour KJSPGT SEGACT KJSPGT NTOTPO=KJSPGT.NUM(/2) NTOGPO=nbpts JG=NTOGPO SEGINI KRSPGT * SEGACT KRSPGT CALL RSETXI(KRSPGT.LECT,KJSPGT.NUM,NTOTPO) *STAT CALL PRMSTA(' Construction KJSPGT et KRSPGT',MSTAT,IMPR) SEGDES KRSPGT SEGDES KJSPGT * * Construction de l'ensemble des noms d'inconnues possibles LITOT * et attribution d'un ordre. * On voudra qu'un ddl d'ordre i soit après au moins un ddl d'ordre * i-1 avec lequel il a une relation * LITOT : liste des noms d'inconnues * In INCOR2 : SEGINI LITOT SEGDES LITOT * SEGINI LINIV * SEGINI LITYP C!* CALL INCORD(MATELE,LITOT,LIORD,IMPR,IRET) CALL INCOR2(MATELE,IMULAG,LITOT,LITYP,LINIV,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'L''ensemble des inconnues est :' SEGPRT,LITOT WRITE(IOIMP,*) 'Type :' SEGPRT,LITYP WRITE(IOIMP,*) 'Niveau :' SEGPRT,LINIV ENDIF *STAT CALL PRMSTA(' Construction LITOT',MSTAT,IMPR) * * Construire le repérage des inconnues KMINCT * SEGACT LITOT NTOTIN=LITOT.MOTS(/2) NPT=NTOTPO NBI=NTOTIN SEGINI KMINCT * Initialisation de la liste des noms d'inconnues (LISINC) DO 48 IBI=1,NBI KMINCT.LISINC(IBI)=LITOT.MOTS(IBI)(1:8) 48 CONTINUE SEGSUP LITOT * Construction de MPOS SEGACT KRSPGT SEGACT MATELE DO 5 IMATE=1,NMATE IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL * On parcourt la primale LNM=IMATEL.LISPRI(/1) NME=IMATEL.LISPRI(/2) JG=NME SEGINI KRINCP CALL CREPER(LNM,NME,NTOTIN,IMATEL.LISPRI,KMINCT.LISINC, $ KRINCP.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '1' GOTO 9999 ENDIF * On supprimme les doublons dans KRINCP JG=NME SEGINI KRIPUN CALL IUNIQ(KRINCP.LECT,NME, $ KRIPUN.LECT,NMEUNI, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP KRINCP MLPPRI=GPMLPP.LISMEL(IMATE) SEGACT MLPPRI NPOPRI=MLPPRI.NUM(/2) CALL MKMPOS(NMEUNI,NPOPRI,NTOGPO,NTOTPO,NTOTIN, $ KRIPUN.LECT,MLPPRI.NUM,KRSPGT.LECT, $ KMINCT.MPOS, $ IMPR,IRET) SEGDES MLPPRI SEGSUP KRIPUN * On parcourt la duale LNM=IMATEL.LISDUA(/1) NME=IMATEL.LISDUA(/2) JG=NME SEGINI KRINCD CALL CREPER(LNM,NME,NTOTIN, $ IMATEL.LISDUA,KMINCT.LISINC, $ KRINCD.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '2' GOTO 9999 ENDIF * On supprime les doublons dans KRINCD JG=NME SEGINI KRIDUN CALL IUNIQ(KRINCD.LECT,NME, $ KRIDUN.LECT,NMEUNI, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP KRINCD MLPDUA=GPMLPD.LISMEL(IMATE) SEGACT MLPDUA NPODUA=MLPDUA.NUM(/2) CALL MKMPOS(NMEUNI,NPODUA,NTOGPO,NTOTPO,NTOTIN, $ KRIDUN.LECT,MLPDUA.NUM,KRSPGT.LECT, $ KMINCT.MPOS, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES MLPDUA SEGSUP KRIDUN SEGDES IMATEL 5 CONTINUE SEGDES KRSPGT * * Remplissage de NPOS(IPT) repérage dans le nb. total de ddl * CALL MKNPOS(NTOTPO,NTOTIN,KMINCT.MPOS, $ KMINCT.NPOS, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'Le repérage des inconnues est :' SEGPRT,KMINCT ENDIF SEGDES KMINCT *STAT CALL PRMSTA(' Construction KMINCT',MSTAT,IMPR) * * On change de stratégie : on construit d'abord le profil Morse total * Puis, on le remplit avec le contenu des matrices élémentaires * On construit le profil Morse diagonale pour initialiser * NBPM=1 DO IMATE=1,NMATE ITYMAT=MATELE.IRIGEL(7,IMATE) * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN IF (ITYMAT.EQ.4) THEN NBPM=NBPM+2 ELSE NBPM=NBPM+1 ENDIF ENDDO SEGINI PMORSS IPM=0 * SEGACT KMINCT NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 SEGDES KMINCT JG=NTTDDL SEGINI LDDLDU CALL ISETI(LDDLDU.LECT,NTTDDL) SEGDES LDDLDU NTT=NTTDDL NJA=NTTDDL SEGINI PMTOT CALL ISETI(PMTOT.IA,NTTDDL+1) CALL ISETI(PMTOT.JA,NTTDDL) SEGDES PMTOT * IPM=IPM+1 PMORSS.LISDD(IPM)=LDDLDU PMORSS.LISPM(IPM)=PMTOT * DO 7 IMATE=1,NMATE *STAT CALL INMSTA(MSPRM,0) MELPRI=MATELE.IRIGEL(1,IMATE) MELDUA=MATELE.IRIGEL(2,IMATE) IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL SEGACT KMINCT * repérage dans la primale LNM=IMATEL.LISPRI(/1) NME=IMATEL.LISPRI(/2) JG=NME SEGINI KRINCP CALL CREPER(LNM,NME,NTOTIN, $ IMATEL.LISPRI,KMINCT.LISINC, $ KRINCP.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '3' GOTO 9999 ENDIF * repérage dans la duale LNM=IMATEL.LISDUA(/1) NME=IMATEL.LISDUA(/2) JG=NME SEGINI KRINCD CALL CREPER(LNM,NME,NTOTIN, $ IMATEL.LISDUA,KMINCT.LISINC, $ KRINCD.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '4' GOTO 9999 ENDIF SEGDES KMINCT MLPDUA=GPMLPD.LISMEL(IMATE) SEGACT MLPDUA NPODUA=MLPDUA.NUM(/2) NTOGPO=nbpts JG=NTOGPO SEGINI KRSPGD CALL RSETXI(KRSPGD.LECT,MLPDUA.NUM,NPODUA) SEGDES MLPDUA * * Construire le profil Morse * * SEGINI PMCOU CALL MAKPR2(MELPRI,KRINCP, $ MELDUA,NPODUA,MLPDUA,KRSPGD,KRINCD, $ KMINCT,KRSPGT, $ LDDLDU,PMCOU, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IPM=IPM+1 PMORSS.LISDD(IPM)=LDDLDU PMORSS.LISPM(IPM)=PMCOU * SEGPRT,LDDLDU * SEGPRT,PMCOU SEGSUP KRSPGD SEGSUP KRINCD SEGSUP KRINCP SEGDES IMATEL * * Cas particulier : celui des matrices CCt * ITYMAT=MATELE.IRIGEL(7,IMATE) * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN IF (ITYMAT.EQ.4) THEN * In MAKPMT : SEGINI PMCO2 CALL TRPMO2(LDDLDU,PMCOU,NTTDDL, $ LDDLDT,PMCOT, $ IMPR,IRET) IPM=IPM+1 PMORSS.LISDD(IPM)=LDDLDT PMORSS.LISPM(IPM)=PMCOT * SEGPRT,LDDLDT * SEGPRT,PMCOT ENDIF IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'Le ',IMATE,'eme profil Morse est :' SEGPRT,PMCOU ENDIF C CALL PRMSTA(' Assemblage profil Morse élémentaire',MSPRM C $ ,IMPR) 7 CONTINUE *STAT CALL PRMSTA(' Assemblage profils Morse élémentaire',MSPRM *STAT $ ,IMPR) * * on effectue le ET sur les profils Morse * * WRITE(IOIMP,*) 'METASS=',METASS IF (METASS.EQ.3) THEN CALL FUSPR3(PMORSS,NTTDDL, $ PMTOT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (METASS.EQ.4) THEN CALL FUSPR4(PMORSS,NTTDDL, $ PMTOT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (METASS.EQ.5) THEN CALL FUSPR5(PMORSS,NTTDDL, $ PMTOT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE WRITE(IOIMP,*) 'Programming error' GOTO 9999 ENDIF * WRITE(IOIMP,*) 'Apres fuspr' * * Suppression de PMORSS * DO IPM=1,PMORSS.LISDD(/1) LDDLDU=PMORSS.LISDD(IPM) SEGSUP LDDLDU PMCOU=PMORSS.LISPM(IPM) SEGSUP PMCOU ENDDO SEGSUP PMORSS * In FUSPRM : SEGINI PMTO2 C CALL FUSPRM(PMTOT,PMCOU, C $ PMTO2, C $ IMPR,IRET) C IF (IRET.NE.0) GOTO 9999 * CALL FUSPR2(PMTOT,PMCOU,NTTDDL, * $ PMTO2, * $ IMPR,IRET) * IF (IRET.NE.0) GOTO 9999 C SEGSUP PMCOU C SEGSUP PMTOT C PMTOT=PMTO2 *STAT CALL PRMSTA(' Fusion des profils Morse élémentaire',MSPRM,IMPR) *STAT CALL PRMSTA(' Assemblage du profil Morse total',MSTAT,IMPR) * * Essai d'une matrice avec plusieurs colonnes égales * C NTT=5 C NJA=5 C SEGINI PMTOT C PMTOT.IA(1)=1 C PMTOT.IA(2)=1+NJA C PMTOT.IA(3)=1+NJA C PMTOT.IA(4)=1+NJA C PMTOT.IA(5)=1+NJA C PMTOT.IA(6)=1+NJA C PMTOT.JA(1)=3 C PMTOT.JA(2)=3 C PMTOT.JA(3)=2 C PMTOT.JA(4)=1 C PMTOT.JA(5)=2 * * Ordonnancement du profil Morse total * SEGACT PMTOT*MOD * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1)) * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1)) NTTDDL=PMTOT.IA(/1)-1 NNZTOT=PMTOT.JA(/1) JG=MAX(NTTDDL+1,2*NNZTOT) SEGINI IWORK CALL CSORT(PMTOT.IA(/1)-1,RDUMMY,PMTOT.JA,PMTOT.IA, $ IWORK.LECT,.FALSE.) SEGSUP IWORK SEGDES PMTOT *STAT CALL PRMSTA(' Ordonnancement du profil Morse total',MSTAT,IMPR) * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1)) * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1)) * 2020 FORMAT (20(2X,I4) ) * * * * Compactage du profil Morse * IF (METASS.EQ.5) THEN PMORS=PMTOT SEGACT PMORS*MOD INEW=1 NTT=IA(/1)-1 DO ITT=1,NTT IDEB=IA(ITT) IFIN=IA(ITT+1)-1 JNEW=-1 IA(ITT)=INEW DO IJA=IDEB,IFIN JOLD=JA(IJA) IF (JNEW.NE.JOLD) THEN JNEW=JOLD JA(INEW)=JNEW INEW=INEW+1 ENDIF ENDDO ENDDO IA(NTT+1)=INEW * WRITE(IOIMP,*) 'Compactage 1' * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1)) * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1)) * WRITE(IOIMP,*) 'ICUR=',ICUR * WRITE(IOIMP,*) 'IDEC=',IDEC * IA(NTT+1)=IA(NTT+1)-IDEC NJA=INEW-1 SEGADJ PMORS SEGDES PMORS * WRITE(IOIMP,*) 'Compactage 2' * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1)) * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1)) ENDIF * * Assemblage des matrices élémentaires * NBVA=NNZTOT SEGINI IZATOT SEGDES IZATOT DO 77 IMATE=1,NMATE *STAT CALL INMSTA(MSMAT,0) MELPRI=MATELE.IRIGEL(1,IMATE) MELDUA=MATELE.IRIGEL(2,IMATE) IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL SEGACT KMINCT * repérage dans la primale LNM=IMATEL.LISPRI(/1) NME=IMATEL.LISPRI(/2) JG=NME SEGINI KRINCP CALL CREPER(LNM,NME,NTOTIN, $ IMATEL.LISPRI,KMINCT.LISINC, $ KRINCP.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '5' GOTO 9999 ENDIF * repérage dans la duale LNM=IMATEL.LISDUA(/1) NME=IMATEL.LISDUA(/2) JG=NME SEGINI KRINCD CALL CREPER(LNM,NME,NTOTIN, $ IMATEL.LISDUA,KMINCT.LISINC, $ KRINCD.LECT, $ IMPR,IRET) IF (IRET.NE.0) THEN WRITE(IOIMP,*) '6' GOTO 9999 ENDIF SEGDES KMINCT CALL MKIZA(MELDUA,MELPRI,IMATEL, $ KRINCD,KRINCP,KMINCT,KRSPGT, $ PMTOT, $ IZATOT, $ IMPR,IRET) * Gestion du CTRL-C if (ierr.NE.0) return IF (IRET.NE.0) GOTO 9999 * * Cas particulier : celui des matrices CCt * ITYMAT=MATELE.IRIGEL(7,IMATE) * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN IF (ITYMAT.EQ.4) THEN CALL MKIZAT(MELDUA,MELPRI,IMATEL, $ KRINCD,KRINCP,KMINCT,KRSPGT, $ PMTOT, $ IZATOT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF SEGSUP KRINCD SEGSUP KRINCP SEGDES IMATEL * CALL PRMSTA(' Assemblage mat. élémentaire',MSMAT,IMPR) 77 CONTINUE SEGSUP KRSPGT *STAT CALL PRMSTA(' Assemblage mat. élém. total',MSTAT,IMPR) * * Renumérotation * IF (IMPR.GT.3) THEN CALL PROFI2(PMTOT,IPROFI,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI ENDIF * IF (LTIME) THEN call timespv(ittime,oothrd) ITI2=(ITTIME(1)+ITTIME(2))/10 ENDIF C!* Calcul C! IF (IMULAG.EQ.1) THEN C! CALL RENUME(PMTOT,IRENU, C! $ NEWNUM, C! $ IMPR,IRET) C! IF (IRET.NE.0) GOTO 9999 C!* Modification de la nouvelle numérotation C!* pour placer les multiplicateurs de Lagrange C!* après les inconnues auxquelles ils se rapportent C! CALL MODNUM(LILAG,KMINCT,PMTOT, C! $ NEWNUM, C! $ IMPR,IRET) C! IF (IRET.NE.0) GOTO 9999 C! ELSEIF (IMULAG.EQ.2) THEN C!* Autre facon de calculer la renumerotation C! CALL CALNUM(LILAG,KMINCT,PMTOT, C! $ IRENU, C! $ NEWNUM, C! $ IMPR,IRET) C! IF (IRET.NE.0) GOTO 9999 C! ELSEIF (IMULAG.EQ.3) THEN C!* Dernière facon de calculer la renumerotation C! CALL CALNU2(LILAG,KMINCT,PMTOT, C! $ IRENU, C! $ NEWNUM, C! $ IMPR,IRET) C! IF (IRET.NE.0) GOTO 9999 *!! ELSEIF (IMULAG.EQ.4) THEN IF (IMULAG.EQ.1) THEN CALL RENUME(PMTOT,IRENU, $ NEWNUM, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 C! ELSEIF (IMULAG.EQ.5) THEN C! CALL CALNU3(LIORD,KMINCT,PMTOT, C! $ IRENU, C! $ NEWNUM, C! $ IMPR,IRET) C! IF (IRET.NE.0) GOTO 9999 ELSEIF (IMULAG.EQ.2.OR.IMULAG.EQ.4) THEN CALL CALNU4(LITYP,LINIV,KMINCT,PMTOT, $ IRENU, $ NEWNUM, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (IMULAG.EQ.3.OR.IMULAG.EQ.5) THEN CALL CALNU5(LITYP,LINIV,KMINCT,PMTOT, $ IRENU, $ NEWNUM, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE WRITE(IOIMP,*) 'Erreur dans la programmation' WRITE(IOIMP,*) 'IMULAG=',IMULAG ENDIF * Gestion du CTRL-C if (ierr.NE.0) return SEGSUP LITYP SEGSUP LINIV IF (LTIME) THEN call timespv(ittime,oothrd) ITI3=(ITTIME(1)+ITTIME(2))/10 ENDIF *STAT CALL PRMSTA(' Calcul de la renumérotation',MSTAT,IMPR) * Permutation de la matrice SEGACT PMTOT SEGACT IZATOT NTT=PMTOT.IA(/1)-1 NJA=PMTOT.JA(/1) SEGINI PMTO2 NBVA=IZATOT.A(/1) SEGINI IZATO2 SEGACT NEWNUM JOB=1 CALL DPERM(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA, $ IZATO2.A,PMTO2.JA,PMTO2.IA,NEWNUM.LECT,NEWNUM.LECT, $ JOB) SEGDES NEWNUM SEGDES IZATO2 SEGDES PMTO2 SEGSUP PMTOT SEGSUP IZATOT PMTOT=PMTO2 IZATOT=IZATO2 *STAT CALL PRMSTA(' Permutation de la matrice',MSTAT,IMPR) * Ordonnancement des colonnes SEGACT PMTOT*MOD SEGACT IZATOT*MOD JG=MAX(PMTOT.IA(/1),2*PMTOT.JA(/1)) SEGINI IWORK CALL CSORT(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA, $ IWORK.LECT,.TRUE.) SEGSUP IWORK SEGDES IZATOT SEGDES PMTOT *STAT CALL PRMSTA(' Ordonnancement des colonnes',MSTAT,IMPR) * Sauvegarde de la renumérotation NTT=0 NPT=NTTDDL NBLK=0 SEGACT NEWNUM SEGINI,IDMTOT DO 8 ITTDDL=1,NTTDDL IDMTOT.NUAN(ITTDDL)=NEWNUM.LECT(ITTDDL) 8 CONTINUE DO 9 ITTDDL=1,NTTDDL IDMTOT.NUNA(NEWNUM.LECT(ITTDDL))=ITTDDL 9 CONTINUE SEGDES IDMTOT SEGSUP NEWNUM * Suppression des supports de points primaux et duaux SEGSUP,GPMLPD.LISMEL(*) SEGSUP,GPMLPP.LISMEL(*) SEGSUP GPMLPD SEGSUP GPMLPP * * Affichage des infos sur la Matrice Morse * IF (IMPR.GT.3) THEN CALL PROFI2(PMTOT,IPROFI,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI ENDIF * * Remplissage du chapeau * SEGDES MATELE CALL ISMSYM(MATELE, $ LSYM, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT MATELE*MOD IF (LSYM) THEN MATELE.KSYM=0 ELSE MATELE.KSYM=2 ENDIF MATELE.KMINC=KMINCT MATELE.KMINCP=KMINCT MATELE.KMINCD=KMINCT * MATELE.KIZM =MCONEC MATELE.KISPGT=KJSPGT MATELE.KISPGP=KJSPGT MATELE.KISPGD=KJSPGT SEGACT KMINCT NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 SEGDES KMINCT MATELE.KNTTT=NTTDDL MATELE.KNTTP=NTTDDL MATELE.KNTTD=NTTDDL MATELE.KIDMAT(1)=IDMTOT MATELE.KIDMAT(2)=IDMTOT MATELE.KIDMAT(4)=PMTOT MATELE.KIDMAT(5)=IZATOT SEGDES MATELE IF (LTIME) THEN call timespv(ittime,oothrd) ITI4=(ITTIME(1)+ITTIME(2))/10 ITN=ITI3-ITI2 ITR=(ITI4-ITI1)-ITN CHARI='RENUMERO' CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI, $ 'ENTIER ',ITN,XVALR,CHARR,LOGIR,IRETR) CHARI='ASSEMBLA' CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI, $ 'ENTIER ',ITR,XVALR,CHARR,LOGIR,IRETR) ENDIF *STAT CALL PRMSTA(' Fin de l''assemblage',MSTAT,IMPR) *STAT CALL PRMSTA('Total de l''assemblage',MSTOT,IMPR) * * Normal termination * 9998 CONTINUE IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine prase3' RETURN * * End of subroutine PRASE3 * END