Sources Esope | Cast3M

fuspr3
C FUSPR3    SOURCE    PV        20/09/26    21:16:58     10724          
      SUBROUTINE FUSPR3(PMORSS,NTTDDL,
     $     PMTOT,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : FUSPR3
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 à FUSPR3. 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 fuspr3'
      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
*      WRITE(IOIMP,*) 'Partie 1'
*
* Passe 1 : Effectuons le dimensionnement de PMTOT
*
      NNZTOT=0
      DO ITTDUA=1,NTTDDL
*         WRITE(IOIMP,*) 'ITTDUA=',ITTDUA
         LDG=0
* Fin de la liste chaînée
         LAST=-1
         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
*                  WRITE(IOIMP,*) ' IPM=',IPM
*                  segprt,lddcou
*                  segprt,pmcou
* Parcourons la ligne de PMCOU
                  DO JNZCOU=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
                     JACOL=PMCOU.JA(JNZCOU)
                     IF (IWORK.LECT(JACOL).EQ.0) THEN
                        LDG=LDG+1
*                        write(ioimp,*) 'iwork'
                        IWORK.LECT(JACOL)=LAST
                        LAST=JACOL
                     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
*         WRITE(IOIMP,*) 'LDG=',LDG
         NNZTOT=NNZTOT+LDG
* Remise à zéro du segment de travail
         DO ILDG=1,LDG
            IPREC=IWORK.LECT(LAST)
            IWORK.LECT(LAST)=0
            LAST=IPREC
         ENDDO
      ENDDO
*      WRITE(IOIMP,*) 'Partie 2'
*
* Passe 2 : Remplissage de PMTOT
*
* Rétablissement des index
      DO I=1,NBPM
         INDEX.LECT(I)=1
      ENDDO
      JG=NTTDDL
      NTT=NTTDDL
      NJA=NNZTOT
      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
                        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
      SEGSUP INDEX
      SEGSUP IWORK
      SEGDES PMTOT
      DO IPM=1,NBPM
         LDDCOU=PMORSS.LISDD(IPM)
         PMCOU=PMORSS.LISPM(IPM)
         SEGDES LDDCOU
         SEGDES PMCOU
      ENDDO
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine fuspr3'
      RETURN
*
* End of subroutine FUSPR3
*
      END