C CALNUM SOURCE MAGN 09/07/30 21:15:25 6458 SUBROUTINE CALNUM(LILAG,KMINCT,PMTOT, $ IRENU, $ NEWNUM, $ IMPR,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C*********************************************************************** C NOM : CALNUM C PROJET : Noyau linéaire NLIN C DESCRIPTION : Calcul d'une renumérotation avec minimisation d'un C profil PUIS placement des multiplicateurs de Lagrange. C Dans le couple renume-modnum, on effectuait les choses C suivantes : C - minimisation du profil sur l'ensemble des ddl. C - échange multiplicateur-noeuds associés pour que le C multiplicateur ait le plus grand numéro. C Maintenant, on essaie la chose suivante : C - minimisation du profil sur les ddl sans les ML. C - insertion des ML dans la nouvelle numérotation C C IRENU=1 'RIEN' : pas de renumérotation C 2 'SLOA' : algorithme de chez Sloan C 3 'GIPR' : Gibbs-King (profile reduction) C 4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction) 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 : RENUME C APPELES (UTIL.) : ISETI, ISHELI, RSETXI C APPELE PAR : PRASEM C*********************************************************************** C ENTREES : LILAG, KMINCT, PMTOT, IRENU C SORTIES : NEWNUM C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 02/12/99, version initiale C HISTORIQUE : v1, 02/12/99, création C HISTORIQUE : C HISTORIQUE : 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*********************************************************************** -INC CCOPTIO *-INC SMLLOGI SEGMENT MLLOGI LOGICAL LOGI(JG) ENDSEGMENT POINTEUR LILAG.MLLOGI POINTEUR ISDDLA.MLLOGI -INC SMMATRIK POINTEUR KMINCT.MINC INTEGER NJA,NTT POINTEUR PMTOT.PMORS POINTEUR PMRED.PMORS -INC SMLENTI INTEGER JG POINTEUR NEWNUM.MLENTI POINTEUR NUINLA.MLENTI POINTEUR KRDDL.MLENTI POINTEUR LDDNOR.MLENTI POINTEUR LDDLAG.MLENTI POINTEUR NNULAG.MLENTI POINTEUR NNUNOR.MLENTI POINTEUR PRMLAG.MLENTI POINTEUR PRMNOR.MLENTI POINTEUR PRMDDL.MLENTI *STAT-INC SMSTAT * INTEGER IMPR,IRET INTEGER IRENU * INTEGER INULAG,INUNOR INTEGER IJARED,ITOTIN,ITOTLA,ITOTPO,ITTDDL,ITTLAG,ITTNOR INTEGER NTOTI2, JTTDDL, JTTNOR INTEGER NJARED,NTOTIN,NTOTLA,NTOTPO,NTTDDL,NTTLAG,NTTNOR INTEGER J,JSTOP,JSTRT INTEGER NNZERO,NJATOT,POSI INTEGER MAXNNJ * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans calnum' *STAT CALL INMSTA(MSTAT,0) * * Construction de NUINLA : la liste d'entiers telle que : * KMINCT.LISINC(NUINLA.LECT(imulag)), imulag=1..nbulag * sont des noms d'inconnues "mult. lag." * * SEGPRT,LILAG JG=0 SEGINI NUINLA SEGACT LILAG NTOTIN=LILAG.LOGI(/1) DO 1 ITOTIN=1,NTOTIN IF (LILAG.LOGI(ITOTIN)) THEN NUINLA.LECT(**)=ITOTIN ENDIF 1 CONTINUE SEGDES LILAG NTOTLA=NUINLA.LECT(/1) * SEGPRT,NUINLA IF (NTOTLA.GT.0) THEN * * Construction de ISDDLA : c'est un tableau de logique tel que : * ISDDLA.LOGI(ittddl)=.FALSE. si ittddl est un ddl "normal" * =.TRUE. si ittddl est un ML * iddl=1..nttddl * * SEGPRT,KMINCT SEGACT KMINCT NTOTI2=KMINCT.LISINC(/2) IF (NTOTI2.NE.NTOTIN) GOTO 9998 NTOTPO=KMINCT.NPOS(/1)-1 NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 NTTLAG=0 JG=NTTDDL * Par défaut, ce tableau est à .FALSE. SEGINI ISDDLA DO 2 ITOTLA=1,NTOTLA ITOTIN=NUINLA.LECT(ITOTLA) DO 22 ITOTPO=1,NTOTPO POSI=KMINCT.MPOS(ITOTPO,ITOTIN) IF (POSI.NE.0) THEN NTTLAG=NTTLAG+1 ISDDLA.LOGI(KMINCT.NPOS(ITOTPO)+POSI-1)=.TRUE. ENDIF 22 CONTINUE 2 CONTINUE SEGDES KMINCT * SEGPRT,ISDDLA * * Construction des trois tableaux d'entiers suivants : * - LDDNOR(1..NTTNOR) : liste des ddl non ML * - LDDLAG(1..NTTLAG) : liste des ddl ML * - KRDDL (1..NTTDDL) : segment de correspondance dans les * tableaux précédents, pour un ddl de numéro ITTDDL : * - KRDDL(ITTDDL)=ITTNOR avec LDDNOR(ITTNOR)=ITTDDL * - KRDDL(ITTDDL)=-ITTLAG avec LDDLAG(ITTLAG)=ITTDDL * suivant le cas d'un ddl ML ou non ML * NTTNOR=NTTDDL-NTTLAG JG=NTTNOR SEGINI LDDNOR JG=NTTLAG SEGINI LDDLAG JG=NTTDDL SEGINI KRDDL ITTNOR=0 ITTLAG=0 DO 3 ITTDDL=1,NTTDDL IF (ISDDLA.LOGI(ITTDDL))THEN ITTLAG=ITTLAG+1 LDDLAG.LECT(ITTLAG)=ITTDDL KRDDL.LECT(ITTDDL)=-ITTLAG ELSE ITTNOR=ITTNOR+1 LDDNOR.LECT(ITTNOR)=ITTDDL KRDDL.LECT(ITTDDL)=ITTNOR ENDIF 3 CONTINUE SEGSUP ISDDLA * SEGPRT,LDDLAG * SEGPRT,LDDNOR * SEGPRT,KRDDL *STAT CALL PRMSTA(' Préparation renume divers',MSTAT,IMPR) * * Obtention de la nouvelle numérotation des ddl normaux : * - construction du profil morse "réduit" * - appel de la subroutine RENUME * SEGACT PMTOT NNZERO=PMTOT.JA(/1) NTT=NTTNOR NJA=NNZERO SEGINI PMRED IJARED=1 DO 4 ITTNOR=1,NTTNOR ITTDDL=LDDNOR.LECT(ITTNOR) JSTRT=PMTOT.IA(ITTDDL) JSTOP=PMTOT.IA(ITTDDL+1)-1 PMRED.IA(ITTNOR)=IJARED DO 42 J=JSTRT,JSTOP NJATOT=PMTOT.JA(J) NJARED=KRDDL.LECT(NJATOT) IF (NJARED.GT.0) THEN PMRED.JA(IJARED)=NJARED IJARED=IJARED+1 ENDIF 42 CONTINUE 4 CONTINUE PMRED.IA(NTTNOR+1)=IJARED NTT=NTTNOR NJA=IJARED-1 SEGADJ,PMRED SEGDES PMTOT * SEGPRT,PMRED *STAT CALL PRMSTA(' Construction profil réduit',MSTAT,IMPR) CALL RENUME(PMRED,IRENU,NNUNOR,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP PMRED * SEGPRT,NNUNOR *STAT CALL PRMSTA(' Après renume',MSTAT,IMPR) * * Obtention du nouveau numéro de chaque ddl ML : * ici, le max des nouveaux numéros de chaque ddl non ML * qui lui sont reliés * * SEGPRT,PMTOT SEGACT PMTOT SEGACT NNUNOR JG=NTTLAG SEGINI NNULAG DO 5 ITTLAG=1,NTTLAG ITTDDL=LDDLAG.LECT(ITTLAG) MAXNNJ=0 JSTRT=PMTOT.IA(ITTDDL) JSTOP=PMTOT.IA(ITTDDL+1)-1 DO 52 J=JSTRT,JSTOP JTTDDL=PMTOT.JA(J) JTTNOR=KRDDL.LECT(JTTDDL) IF (JTTNOR.GT.0) THEN MAXNNJ=MAX(MAXNNJ,NNUNOR.LECT(JTTNOR)) ENDIF 52 CONTINUE NNULAG.LECT(ITTLAG)=MAXNNJ * NNULAG.LECT(ITTLAG)=NTTDDL+1 5 CONTINUE SEGDES PMTOT SEGSUP KRDDL * SEGPRT,NNULAG * * 1 On calcule la permutation qui permet de trier NNULAG * par ordre croissant de nouveau numéro. * 2 On calcule la permutation réciproque de NNUNOR (ceci * est également la permutation qui permet de trier NNUNOR * par ordre croissant) * JG=NTTLAG SEGINI PRMLAG CALL ISETI(PRMLAG.LECT,NTTLAG) CALL ISHELI(NTTLAG,PRMLAG.LECT,NTTLAG,NNULAG.LECT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * SEGPRT,PRMLAG JG=NTTNOR SEGINI PRMNOR CALL RSETXI(PRMNOR.LECT,NNUNOR.LECT,NTTNOR) SEGSUP NNUNOR * SEGPRT,PRMNOR * * 3 En "merge"ant les deux listes précédentes, on obtient * la permutation réciproque de la nouvelle numérotation * totale que l'on cherche (si, si !) * JG=NTTDDL SEGINI PRMDDL ITTLAG=1 INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) INUNOR=1 DO 6 ITTDDL=1,NTTDDL IF (ITTLAG.LE.NTTLAG.AND.INUNOR.LE.NTTNOR) THEN IF (INULAG.LT.INUNOR) THEN PRMDDL.LECT(ITTDDL)= $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) ITTLAG=ITTLAG+1 IF (ITTLAG.LE.NTTLAG) THEN INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) ENDIF ELSE PRMDDL.LECT(ITTDDL)= $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) INUNOR=INUNOR+1 ENDIF ELSEIF (ITTLAG.LE.NTTLAG) THEN PRMDDL.LECT(ITTDDL)= $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) ITTLAG=ITTLAG+1 IF (ITTLAG.LE.NTTLAG) THEN INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) ENDIF ELSEIF (INUNOR.LE.NTTNOR) THEN PRMDDL.LECT(ITTDDL)= $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) INUNOR=INUNOR+1 ELSE WRITE(IOIMP,*) 'Error' ENDIF * write(ioimp,*) 'prmddl=',PRMDDL.LECT(ITTDDL) 6 CONTINUE SEGSUP PRMNOR SEGSUP PRMLAG SEGSUP NNULAG SEGSUP LDDLAG SEGSUP LDDNOR * SEGPRT,PRMDDL * * D'où la nouvelle numérotation : * JG=NTTDDL SEGINI NEWNUM CALL RSETXI(NEWNUM.LECT,PRMDDL.LECT,NTTDDL) SEGDES NEWNUM SEGSUP PRMDDL *STAT CALL PRMSTA(' Merge et obtention NEWNUM',MSTAT,IMPR) ELSEIF(NTOTLA.EQ.0) THEN CALL RENUME(PMTOT,IRENU, $ NEWNUM, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF * SEGPRT,NEWNUM SEGSUP NUINLA * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9998 CONTINUE WRITE(IOIMP,*) 'Pb. compatibilité d''objets (dimensions)' 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine calnum' RETURN * * End of subroutine CALNUM * END