Sources Esope | Cast3M

mkpmor
C MKPMOR    SOURCE    PV        20/09/26    21:18:57     10724          
      SUBROUTINE MKPMOR(LPDPP,KJSPGD,KRINCP,KRINCD,
     $     KRSPGT,KMINCT,
     $     PMCOU,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : MKPMOR
C PROJET      : Assemblage matrice élémentaire -> matrice Morse
C DESCRIPTION : Matrice élémentaire + liste indexée d'entiers(popoin) =>
C               Profil Morse de la matrice assemblée (les colonnes ne
C               sont pas ordonnées).
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          : CORINC
C APPELE PAR       : MAKPRM
C***********************************************************************
C ENTREES            : LPDPP, KJSPGD, KRINCP, KRINCD, KRSPGT, KMINCT
C SORTIES            : PMCOU
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 06/10/99, version initiale
C HISTORIQUE : v1, 06/10/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***********************************************************************
*
*
* On peut optimiser les boucles en sortant les NPOS
*
*
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
      POINTEUR KJSPGD.MELEME
-INC SMMATRIK
      POINTEUR KMINCT.MINC
      INTEGER NTT,NJA
      POINTEUR PMCOU.PMORS
-INC SMLENTI
      INTEGER JG
      POINTEUR KRINCD.MLENTI
      POINTEUR KRIDUN.MLENTI
      POINTEUR KRINCP.MLENTI
      POINTEUR KRSPGT.MLENTI
      POINTEUR DD2DP.MLENTI
*
* Includes perso
*
*-INC SLSTIND
*
*     Segment LSTIND (liste séquentielle indexée)
*
      SEGMENT LSTIND
      INTEGER IDX(NBM+1)
      INTEGER IVAL(NBTVAL)
      ENDSEGMENT
*
*     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
*
*     NBM      : NOMBRE DE MULTIPLETS
*     NBTVAL   : NOMBRE TOTAL DE VALEURS
*     IDX(I)   : INDICE DE LA PREMIERE VALEUR DU IEME
*                MULTIPLET DANS LE TABLEAU IVAL
*     IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
      POINTEUR LIPUN.LSTIND
      POINTEUR LPDPP.LSTIND
*
      INTEGER IMPR,IRET
*
      LOGICAL LEXIST
      INTEGER IDEPA
      INTEGER IDUNIQ,IPUNIQ,IPDUA,IPPRI,ITTDDL
      INTEGER NDUNIQ,NPDUA,      NTTDDL
      INTEGER NOPPR,NOPDU
      INTEGER NUTPPR,NUTPDU,NUTDPR,NUTDDU
      INTEGER NTOTCO,NTOTPO
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mkpmor'
C Pour chaque composante primale distincte, il faudrait déterminer
C avec quels composantes duales distinctes il est relié :
C Par exemple, si on a :
C      KRINCD = 1  1  1  2
C      KRINCP = 2  2  3  4
C On a :    KRIDUN =  1     2
C On veut :  LIPUN = (2 3) (4) (c'est une liste indexée)
C
      CALL CORINC(KRINCD,KRINCP,
     $     KRIDUN,LIPUN,
     $     IMPR,IRET)
C     - Construire la liste d'entiers suivante (DD2DP) :
C         * Nombre d'entiers = nb total de ddl (primaux) ;
C         * pour chaque ddl primal : nb. total de ddl duaux qui lui
C           sont reliés.
      SEGACT KRIDUN
      NDUNIQ=KRIDUN.LECT(/1)
      SEGACT LIPUN
      SEGACT KJSPGD
      SEGACT KRSPGT
      SEGACT KMINCT
      NTOTPO=KMINCT.NPOS(/1)-1
      NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
      JG=NTTDDL
      SEGINI DD2DP
      SEGACT LPDPP
      NPDUA=KJSPGD.NUM(/2)
      DO 1 IPDUA=1,NPDUA
         NOPDU=KJSPGD.NUM(1,IPDUA)
         NUTPDU=KRSPGT.LECT(NOPDU)
         IF (NUTPDU.EQ.0) THEN
            WRITE(IOIMP,*) 'C''est dual grave...'
            GOTO 9999
         ENDIF
         DO 12 IDUNIQ=1,NDUNIQ
            LEXIST=(KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ)).NE.0)
            IF (.NOT.LEXIST) THEN
               WRITE(IOIMP,*) 'C''est comp. duale grave...'
               GOTO 9999
            ENDIF
            NUTDDU=KMINCT.NPOS(NUTPDU)
     $           +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1
            DD2DP.LECT(NUTDDU)=(LIPUN.IDX(IDUNIQ+1)-LIPUN.IDX(IDUNIQ))
     $           *(LPDPP.IDX(IPDUA+1)-LPDPP.IDX(IPDUA))
 12      CONTINUE
 1    CONTINUE
C
C     - Dimensionner le profil Morse
C
      NTOTCO=0
      DO 3 ITTDDL=1,NTTDDL
         NTOTCO=NTOTCO+DD2DP.LECT(ITTDDL)
 3    CONTINUE
      NTT=NTTDDL
      NJA=NTOTCO
      SEGINI PMCOU
C
C     - Remplissage du profil de la matrice Morse :
C       * Le tableau IA :
      PMCOU.IA(1)=1
      DO 5 ITTDDL=1,NTTDDL
         PMCOU.IA(ITTDDL+1)=PMCOU.IA(ITTDDL)
     $                     +DD2DP.LECT(ITTDDL)
 5    CONTINUE
      SEGSUP DD2DP
C       * Le tableau JA :
      DO 7 IPDUA=1,NPDUA
         NOPDU=KJSPGD.NUM(1,IPDUA)
         NUTPDU=KRSPGT.LECT(NOPDU)
         DO 72 IDUNIQ=1,NDUNIQ
            NUTDDU=KMINCT.NPOS(NUTPDU)
     $           +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1
            IDEPA=PMCOU.IA(NUTDDU)
            DO 722 IPPRI=LPDPP.IDX(IPDUA),LPDPP.IDX(IPDUA+1)-1
               NOPPR=LPDPP.IVAL(IPPRI)
               NUTPPR=KRSPGT.LECT(NOPPR)
               DO 7222 IPUNIQ=LIPUN.IDX(IDUNIQ),LIPUN.IDX(IDUNIQ+1)-1
                  NUTDPR=KMINCT.NPOS(NUTPPR)
     $                 +KMINCT.MPOS(NUTPPR,LIPUN.IVAL(IPUNIQ))-1
                  PMCOU.JA(IDEPA)=NUTDPR
                  IDEPA=IDEPA+1
 7222          CONTINUE
 722        CONTINUE
 72      CONTINUE
 7    CONTINUE
      SEGDES PMCOU
      SEGDES LPDPP
      SEGDES KMINCT
      SEGDES KRSPGT
      SEGDES KJSPGD
      SEGSUP LIPUN
      SEGSUP KRIDUN
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine mkpmor'
      RETURN
*
* End of subroutine MKPMOR
*
      END