Sources Esope | Cast3M

trpmo2
C TRPMO2    SOURCE    PV        20/09/26    21:20:05     10724          
      SUBROUTINE TRPMO2(LDDLDU,PMCOU,NTTDDL,
     $     LDDLDT,PMCOT,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : TRPMO2
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : Construction du profil Morse (non ordonné) de (C + Ct) à
C               partir du profil Morse (non ordonné) de 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          : TRPMOR, FUSPRM
C APPELE PAR       : PRASEM
C***********************************************************************
C ENTREES            : PMC
C SORTIES            : PMCCT
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 17/03/06, version 1
C HISTORIQUE : v1, 17/03/06, création
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 PMCOU.PMORS
      POINTEUR PMCOT.PMORS
-INC SMLENTI
      POINTEUR LDDLDU.MLENTI
      POINTEUR LDDLDT.MLENTI
      POINTEUR KDDLDT.MLENTI
      POINTEUR ITRAV.MLENTI
*
      INTEGER IMPR,IRET
*
* Executable statements
*
      IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans trpmo2'
*      SEGPRT,LDDLDU
*      SEGPRT,PMCOU
      SEGACT LDDLDU
      NDDLDU=LDDLDU.LECT(/1)
      SEGACT,PMCOU
      NJA=PMCOU.JA(/1)
*
* Trouvons la liste des ddl duaux de la transposée
*
      JG=NTTDDL
      SEGINI ITRAV
      DO IJA=1,NJA
         ICOL=PMCOU.JA(IJA)
         ITRAV.LECT(ICOL)=ITRAV.LECT(ICOL)+1
      ENDDO
* Dimension
      NDDLDT=0
      DO ITTDDL=1,NTTDDL
         IF (ITRAV.LECT(ITTDDL).GT.0) THEN
            NDDLDT=NDDLDT+1
         ENDIF
      ENDDO
* Remplissage
      JG=NDDLDT
      SEGINI LDDLDT
      IDDLDT=0
      DO ITTDDL=1,NTTDDL
         IF (ITRAV.LECT(ITTDDL).GT.0) THEN
            IDDLDT=IDDLDT+1
            LDDLDT.LECT(IDDLDT)=ITTDDL
         ENDIF
      ENDDO
*
* Remplissage du segment IA de la transposée
*
      NTT=NDDLDT
      SEGINI,PMCOT
      PMCOT.IA(1)=1
      DO IDDLDT=1,NDDLDT
         ICOL=LDDLDT.LECT(IDDLDT)
         PMCOT.IA(IDDLDT+1)=PMCOT.IA(IDDLDT)+ITRAV.LECT(ICOL)
      ENDDO
*      SEGSUP ITRAV
* Repérage dans LDDLDT en réutilisant ITRAV
*      JG=NTTDDL
*      SEGINI KDDLDT
      KDDLDT=ITRAV
      CALL RSETXI(KDDLDT.LECT,LDDLDT.LECT,NDDLDT)
      SEGDES LDDLDT
*
* Remplissage de JA en se servant de IA comme liste de pointeurs
* courant dans JA
*
      DO IDDLDU=1,NDDLDU
         JSTRT=PMCOU.IA(IDDLDU)
         JSTOP=PMCOU.IA(IDDLDU+1)-1
         DO J=JSTRT,JSTOP
*            WRITE(IOIMP,*) 'J=',J
            JCOL=PMCOU.JA(J)
*            WRITE(IOIMP,*) 'JCOL=',JCOL
            ICOL=KDDLDT.LECT(JCOL)
*            WRITE(IOIMP,*) 'ICOL=',ICOL
            I=PMCOT.IA(ICOL)
*            WRITE(IOIMP,*) 'I=',I
            PMCOT.JA(I)=LDDLDU.LECT(IDDLDU)
            PMCOT.IA(ICOL)=I+1
         ENDDO
      ENDDO
      SEGSUP KDDLDT
      SEGDES PMCOU
      SEGDES LDDLDU
*
* Restauration de IA
*
      DO IDDLDT=NDDLDT,2,-1
         PMCOT.IA(IDDLDT)=PMCOT.IA(IDDLDT-1)
      ENDDO
      PMCOT.IA(1)=1
      SEGDES PMCOT
*      SEGPRT,LDDLDT
*      SEGPRT,PMCOT
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine trpmo2'
      RETURN
*
* End of subroutine TRPMO2
*
      END