Sources Esope | Cast3M

mkpmo3
C MKPMO3    SOURCE    GOUNAND   25/04/30    21:15:21     12258          
      SUBROUTINE MKPMO3(LPDPP,KJSPGD,KRINCP,KRINCD,
     $     KRSPGT,KMINCT,
     $     LDDLDU,PMCOU,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : MKPMO3
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     Basé sur mkpmo2, mais ici les lignes ne sont pas non plus
C     ordonnées.
C
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          : 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, 09/02/2016, version initiale
C HISTORIQUE : v1, 09/02/2016, 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
      POINTEUR LDDLDU.MLENTI
      POINTEUR KDDLDU.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 mkpmo3'
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)
      IF (IRET.NE.0) GOTO 9999
      NDUNIQ=KRIDUN.LECT(/1)
      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)
      nddldu=npdua*nduniq
      jg=nddldu
      segini lddldu
      segact lpdpp
      nja=0
      do ipdua=1,npdua
         nppri=LPDPP.IDX(IPDUA+1)-LPDPP.IDX(IPDUA)
         do iduniq=1,nduniq
            npuniq=LIPUN.IDX(IDUNIQ+1)-LIPUN.IDX(IDUNIQ)
            nja=nja+(npuniq*nppri)
         enddo
      enddo
 
*      write(ioimp,*) 'dimensionnement'
*      write(ioimp,*) 'nddldu= ',nddldu
*      write(ioimp,*) 'nja=    ',nja
      ntt=nddldu
      segini pmcou
*
      iddldu=1
      ija=1
*      pmcou.ia(1)=ija
      do ipdua=1,npdua
         nutpdu=krspgt.lect(kjspgd.num(1,ipdua))
         do iduniq=1,nduniq
            nutddu=KMINCT.NPOS(NUTPDU)
     $           +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1
            lddldu.lect(iddldu)=nutddu
            pmcou.ia(iddldu)=ija
            iddldu=iddldu+1
            do ippri=LPDPP.IDX(IPDUA),LPDPP.IDX(IPDUA+1)-1
               nutppr=krspgt.lect(lpdpp.ival(ippri))
               do ipuniq=LIPUN.IDX(IDUNIQ),LIPUN.IDX(IDUNIQ+1)-1
                  NUTDPR=KMINCT.NPOS(NUTPPR)
     $                 +KMINCT.MPOS(NUTPPR,LIPUN.IVAL(IPUNIQ))-1
                  pmcou.ja(ija)=nutdpr
                  ija=ija+1
               enddo
            enddo
         enddo
      enddo
      pmcou.ia(iddldu)=ija
*      write(ioimp,*) 'profil morse'
*      write(ioimp,*) 'iddldu= ',iddldu
*      write(ioimp,*) 'ija=    ',ija
*      stop 16
 
      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 mkpmo3'
      RETURN
*
* End of subroutine MKPMO3
*
      END