C PRASEM SOURCE PV 20/09/26 21:19:13 10724 SUBROUTINE PRASEM(MATELE,MRENU,MMULAG,METASS, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : PRASEM 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 -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 -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 INTEGER NBLK POINTEUR IDMTOT.IDMAT * * 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 * 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 * C C Définition des options C INTEGER LNOPT PARAMETER (LNOPT=4) 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) CHARACTER*(LNOPT) MRENU INTEGER IRENU,NRENU PARAMETER (NRENU=4) POINTEUR LRENU.MLMOTS 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 CHARACTER*(LNOPT) MMULAG INTEGER IMULAG,NMULAG C! PARAMETER (NMULAG=6) PARAMETER (NMULAG=5) POINTEUR LMULAG.MLMOTS C C Initialisation des tableaux d'options C JGN=LNOPT JGM=NRENU SEGINI LRENU LRENU.MOTS(1)='RIEN' LRENU.MOTS(2)='SLOA' LRENU.MOTS(3)='GIPR' LRENU.MOTS(4)='GIBA' JGN=LNOPT JGM=NMULAG SEGINI LMULAG C! LMULAG.MOTS(1)='ECHA' C! LMULAG.MOTS(2)='APRE' C! LMULAG.MOTS(3)='APR2' C! LMULAG.MOTS(4)='RIEN' C! LMULAG.MOTS(5)='APR3' C! LMULAG.MOTS(6)='APR4' LMULAG.MOTS(1)='RIEN' LMULAG.MOTS(2)='APR2' LMULAG.MOTS(3)='APR3' LMULAG.MOTS(4)='APR4' LMULAG.MOTS(5)='APR5' * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prasem' * * Lecture des données (options renumérotation et mult.lag) * CALL FIMOTS(MRENU,LRENU,IRENU,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FIMOTS(MMULAG,LMULAG,IMULAG,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP LMULAG SEGSUP LRENU *STAT CALL INMSTA(MSTAT,IMPR) *STAT CALL INMSTA(MSTOT,0) * * Quelques tests * SEGACT MATELE NMATE=MATELE.IRIGEL(/2) 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 * SEGACT KMINCT NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 SEGDES KMINCT NTT=NTTDDL NJA=NTTDDL SEGINI PMTOT CALL ISETI(PMTOT.IA,NTTDDL+1) CALL ISETI(PMTOT.JA,NTTDDL) SEGDES 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 MAKPRM(MELPRI,KRINCP, $ MELDUA,NPODUA,MLPDUA,KRSPGD,KRINCD, $ KMINCT,KRSPGT, $ PMCOU, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 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 MAKPMT(PMCOU, $ PMCO2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP PMCOU PMCOU=PMCO2 ENDIF IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'Le ',IMATE,'eme profil Morse est :' SEGPRT,PMCOU ENDIF *STAT CALL PRMSTA(' Assemblage profil Morse élémentaire',MSPRM *STAT $ ,IMPR) * * on effectue le ET sur les profils Morse * * In FUSPRM : SEGINI PMTO2 IF (METASS.EQ.1) THEN CALL FUSPRM(PMTOT,PMCOU, $ PMTO2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (METASS.EQ.2) THEN CALL FUSPR2(PMTOT,PMCOU,NTTDDL, $ PMTO2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE WRITE(IOIMP,*) 'Programming error' GOTO 9999 ENDIF SEGSUP PMCOU SEGSUP PMTOT PMTOT=PMTO2 *STAT CALL PRMSTA(' Fusion profil Morse élémentaire',MSPRM,IMPR) 7 CONTINUE *STAT CALL PRMSTA(' Assemblage du profil Morse total',MSTAT,IMPR) * * Ordonnancement du profil Morse total * SEGACT PMTOT*MOD 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) * * 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) 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 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 SEGSUP LITYP SEGSUP LINIV *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 *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 prasem' RETURN * * End of subroutine PRASEM * END