Sources Esope | Cast3M

infmat
C INFMAT    SOURCE    PV        20/09/26    21:17:26     10724          
      SUBROUTINE INFMAT(AMORS,AISA,IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : INFMAT
C DESCRIPTION : Affiche des informations sur une matrice Morse.
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 APPELE PAR       : KRES2
C***********************************************************************
C ENTREES            : AMORS, AISA
C ENTREES/SORTIES    : -
C SORTIES            : -
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1.1, 22/03/2000, version initiale
C HISTORIQUE : v1.1, 22/03/2000,
C Donne plus d'informations (maxi largeur de bande, profil supérieur et
C inférieur).
C HISTORIQUE : v1, 17/01/2000, 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 PPARAM
-INC CCOPTIO
-INC SMMATRIK
      POINTEUR AMORS.PMORS
      POINTEUR AMORS2.PMORS
      POINTEUR AISA.IZA
      INTEGER NTT,NJA
      INTEGER NBVA
      POINTEUR PMWRK.PMORS
      POINTEUR IZAWRK.IZA
*
      INTEGER IMPR,IRET
*
      INTEGER IMAXI,IMAXS,IPROFS,IMIN,ITT
      INTEGER J,JSTRT,JSTOP
      INTEGER NBDDL,NBSTO
      INTEGER IPROFI
      LOGICAL LSPKIT
*
* Executable statements
*
      IF (IMPR.GT.0) THEN
         LSPKIT=.FALSE.
*SPSKIT      LSPKIT=.TRUE.
* Les calculs à effectuer
         IF (IMPR.GT.1) THEN
            SEGACT AMORS
            NBDDL=AMORS.IA(/1)-1
            NBSTO=AMORS.JA(/1)
            SEGDES AMORS
            WRITE(IOIMP,*) 'Matrice Morse : nb.ddl=',NBDDL,
     $           ' ; nb.termesstockés=',NBSTO
            CALL PROFI2(AMORS,IPROFI,0,IRET)
            IF (IMPR.GT.2)THEN
               WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
            ELSEIF (IMPR.GT.3) THEN
               SEGACT AMORS
               NTT=AMORS.IA(/1)-1
               IPROFI=0
               IMAXI=0
               DO 9 ITT=1,NTT
                  IPROFI=IPROFI+(ITT-AMORS.JA(AMORS.IA(ITT)))
                  IMAXI=MAX(IMAXI,ITT-AMORS.JA(AMORS.IA(ITT)))
 9             CONTINUE
               SEGDES AMORS
               WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
               WRITE(IOIMP,*) 'Max. larg. bande = ',IMAXI
               CALL MAKPMT(AMORS,
     $              AMORS2,
     $              IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               IPROFS=0
               IMAXS=0
               SEGACT AMORS2
               NTT=AMORS2.IA(/1)-1
               DO 91 ITT=1,NTT
                  JSTRT=AMORS2.IA(ITT)
                  JSTOP=AMORS2.IA(ITT+1)-1
                  IMIN=AMORS2.JA(JSTRT)
                  DO 912 J=JSTRT+1,JSTOP
                     IMIN=MIN(IMIN,AMORS2.JA(J))
 912              CONTINUE
                  IMIN=ITT-IMIN
                  IPROFS=IPROFS+IMIN
                  IMAXS=MAX(IMAXS,IMIN)
 91            CONTINUE
               SEGSUP AMORS2
               WRITE(IOIMP,*) 'Profil (tri. sup.) = ',IPROFS
               WRITE(IOIMP,*) 'Max larg. bande = ',IMAXS
               WRITE(IOIMP,*) 'Total = ',IPROFS+IPROFI+ITT
            ENDIF
         ENDIF
         IF (LSPKIT) THEN
            SEGACT AMORS
            SEGACT AISA
            NTT=AMORS.IA(/1)-1
            NBVA=AISA.A(/1)
            NJA=MAX(2*NTT+1,NBVA)
            SEGINI PMWRK
            SEGINI IZAWRK
*SPSKIT         CALL DINF13(NTT,IOIMP,AISA.A,AMORS.JA,AMORS.IA,.TRUE.,
*SPSKIT     $        ' Matrice qui tue                               '//
*SPSKIT     $        '                                               ',
*SPSKIT     $        'MAT     ',' N ',IZAWRK.A,PMWRK.JA,PMWRK.IA)
            SEGSUP IZAWRK
            SEGSUP PMWRK
            SEGDES AISA
            SEGDES AMORS
         ENDIF
      ENDIF
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine infmat'
      RETURN
*
* End of subroutine infmat
*
      END