Sources Esope | Cast3M

fuspr4
C FUSPR4    SOURCE    PV        20/09/26    21:16:59     10724          
      SUBROUTINE FUSPR4(PMORSS,NTTDDL,
     $     PMTOT,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : FUSPR4
C PROJET      : Assemblage matrice élémentaire -> matrice Morse
C DESCRIPTION : Assemblage d'un ensemble de profils Morse
C               Le résultat est dans PMTOT.
C               Subroutine quasi-identique à FUSPR4. On
C               suppose la matrice totale carrée
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          :
C APPELE PAR       : PRASEM, MAKPMT
C***********************************************************************
C ENTREES            : PMORSS
C SORTIES            : PMTOT
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 13/12/99, version initiale
C HISTORIQUE : v1, 13/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 PPARAM
-INC CCOPTIO
-INC SMMATRIK
      INTEGER NTT,NJA
      POINTEUR PMCOU.PMORS
      POINTEUR PMTOT.PMORS
*
      SEGMENT PMORSS
      POINTEUR LISDD(NBPM).MLENTI
      POINTEUR LISPM(NBPM).PMORS
      ENDSEGMENT
*
 
-INC SMLENTI
      POINTEUR LDDCOU.MLENTI
      POINTEUR INDEX.MLENTI
      POINTEUR IWORK.MLENTI
*
      INTEGER IMPR,IRET
*
      INTEGER NTTDU2,NTTDUA,NTTPRI
      INTEGER NNZTOT
*
* Executable statements
*
      IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr4'
      NBPM=PMORSS.LISDD(/1)
      JG=NBPM
      SEGINI INDEX
      DO I=1,NBPM
         INDEX.LECT(I)=1
      ENDDO
      JG=NTTDDL
      SEGINI IWORK
      DO IPM=1,NBPM
         LDDCOU=PMORSS.LISDD(IPM)
         PMCOU=PMORSS.LISPM(IPM)
         SEGACT LDDCOU
         SEGACT PMCOU
      ENDDO
*
* Détermination du max de la taille des profils Morse
*
      MAXTAI=0
      DO IPM=1,NBPM
         PMCOU=PMORSS.LISPM(IPM)
         MAXTAI=MAX(MAXTAI,PMCOU.JA(/1))
      ENDDO
* Taille initiale et taille des blocs à allouer pour ajustement
      INITAI=MAXTAI*MIN(2,NBPM)
      INCTAI=MAXTAI
*
* Remplissage de PMTOT
*
      JG=NTTDDL
      NTT=NTTDDL
      NJA=INITAI
      SEGINI PMTOT
      JNZC=0
      PMTOT.IA(1)=1
      DO ITTDUA=1,NTTDDL
         DO IPM=1,NBPM
            LDDCOU=PMORSS.LISDD(IPM)
            PMCOU=PMORSS.LISPM(IPM)
            IDX=INDEX.LECT(IPM)
            IF (IDX.GT.0) THEN
               ITTDCO=LDDCOU.LECT(IDX)
               IF (ITTDCO.EQ.ITTDUA) THEN
* Parcourons la ligne de PMCOU
                  DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
                     JACOL=PMCOU.JA(JNZA)
                     IF (IWORK.LECT(JACOL).EQ.0) THEN
                        JNZC=JNZC+1
                        IF (JNZC.GT.NJA) THEN
                           NJA=NJA+INCTAI
                           SEGADJ,PMTOT
                        ENDIF
                        PMTOT.JA(JNZC)=JACOL
                        IWORK.LECT(JACOL)=JNZC
                     ENDIF
                  ENDDO
                  IDX=IDX+1
                  IF (IDX.LE.LDDCOU.LECT(/1)) THEN
                     INDEX.LECT(IPM)=IDX
                  ELSE
                     INDEX.LECT(IPM)=0
                  ENDIF
               ENDIF
            ENDIF
         ENDDO
* Remise à zéro du segment de travail
         DO INZC=PMTOT.IA(ITTDUA),JNZC
            IWORK.LECT(PMTOT.JA(INZC))=0
         ENDDO
         PMTOT.IA(ITTDUA+1)=JNZC+1
      ENDDO
      DO IPM=1,NBPM
         LDDCOU=PMORSS.LISDD(IPM)
         PMCOU=PMORSS.LISPM(IPM)
         SEGDES LDDCOU
         SEGDES PMCOU
      ENDDO
      SEGSUP INDEX
      SEGSUP IWORK
      NJA=JNZC
      SEGADJ,PMTOT
      SEGDES PMTOT
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine fuspr4'
      RETURN
*
* End of subroutine FUSPR4
*
      END