Sources Esope | Cast3M

fuspr2
C FUSPR2    SOURCE    PV        20/09/26    21:16:57     10724          
      SUBROUTINE FUSPR2(PM1,PM2,NTTPRI,
     $     PMTOT,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : FUSPR2
C PROJET      : Assemblage matrice élémentaire -> matrice Morse
C DESCRIPTION : Profil Morse (non ordonné) de A + profil Morse (non
C               ordonné) de B => profil Morse (non ordonné) de (A + B)
C
C               On effectue un ET sur les profils Morses non
C               ordonnés PM1 et PM2.
C               Le résultat est dans PMTOT.
C               Subroutine quasi-identique à FUSPRM. FUSPRM supposait
C               des profils morse de matrices carrées. Pas FUSPR2.
C               En outre, on fait tout en esope et pas en fortran
C               (pas robuste)
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            : PM1, PM2
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 PM1.PMORS
      POINTEUR PM2.PMORS
      POINTEUR PMTOT.PMORS
-INC SMLENTI
      INTEGER JG
      POINTEUR IWORK.MLENTI
*
      INTEGER IMPR,IRET
*
      INTEGER NTTDU2,NTTDUA,NTTPRI
      INTEGER NNZTOT
*
* Executable statements
*
      IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr2'
      SEGACT PM1
      NTTDUA=PM1.IA(/1)-1
      SEGACT PM2
      NTTDU2=PM2.IA(/1)-1
      IF (NTTDUA.NE.NTTDU2) THEN
         WRITE(IOIMP,*) 'Profils morse à fusionner incompatibles...'
         GOTO 9999
      ENDIF
*
* Passe 1 : Effectuons le dimensionnement de PMTOT
*
      JG=NTTPRI
      SEGINI,IWORK
      NNZTOT=0
      DO ITTDUA=1,NTTDUA
         LDG=0
* Fin de la liste chaînée
         LAST=-1
* Parcourons la ligne de A
         DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
            JACOL=PM1.JA(JNZA)
            IF (IWORK.LECT(JACOL).EQ.0) THEN
               LDG=LDG+1
               IWORK.LECT(JACOL)=LAST
               LAST=JACOL
            ENDIF
         ENDDO
* Parcourons la ligne de B
         DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
            JBCOL=PM2.JA(JNZB)
            IF (IWORK.LECT(JBCOL).EQ.0) THEN
               LDG=LDG+1
               IWORK.LECT(JBCOL)=LAST
               LAST=JBCOL
            ENDIF
         ENDDO
         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
*
* Passe 2 : Remplissage de PMTOT
*
      NTT=NTTDUA
      NJA=NNZTOT
      SEGINI PMTOT
      JNZC=0
      PMTOT.IA(1)=1
      DO ITTDUA=1,NTTDUA
* Parcourons la ligne de A
         DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
            JACOL=PM1.JA(JNZA)
            IF (IWORK.LECT(JACOL).EQ.0) THEN
               JNZC=JNZC+1
               PMTOT.JA(JNZC)=JACOL
               IWORK.LECT(JACOL)=JNZC
            ENDIF
         ENDDO
* Parcourons la ligne de B
         DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
            JBCOL=PM2.JA(JNZB)
            IF (IWORK.LECT(JBCOL).EQ.0) THEN
               JNZC=JNZC+1
               PMTOT.JA(JNZC)=JBCOL
               IWORK.LECT(JBCOL)=JNZC
            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 IWORK
      SEGDES PMTOT
      SEGDES PM2
      SEGDES PM1
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine fuspr2'
      RETURN
*
* End of subroutine FUSPR2
*
      END