Sources Esope | Cast3M

makprm
C MAKPRM    SOURCE    PV        20/09/26    21:18:44     10724          
      SUBROUTINE MAKPRM(MELPRI,KRINCP,
     $     MELDUA,NPODUA,KJSPGD,KRSPGD,KRINCD,
     $     KMINCT,KRSPGT,
     $     PMCOU,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : MAKPRM
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : Matrice élémentaire + repérage => profil Morse de la
C               matrice assemblée (les colonnes ne sont pas
C               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          : PONBL2, POELM2, PONBPO, POPOIN, MKPMOR
C APPELE PAR       : PRASEM
C***********************************************************************
C ENTREES            : tout sauf PMCOU
C SORTIES            : PMCOU
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 13/12/99, création
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 SMELEME
      POINTEUR MELPRI.MELEME
      POINTEUR MELDUA.MELEME
      POINTEUR KJSPGD.MELEME
-INC SMMATRIK
      POINTEUR KMINCT.MINC
      POINTEUR PMCOU.PMORS
-INC SMLENTI
      POINTEUR KRINCP.MLENTI
      POINTEUR KRSPGD.MLENTI
      POINTEUR KRINCD.MLENTI
      POINTEUR KRSPGT.MLENTI
      POINTEUR PONBLD.MLENTI
      POINTEUR PODPOP.MLENTI
      INTEGER NPODUA
*
* Includes perso
*
*STAT -INC SMSTAT
*-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 P2ELDU.LSTIND
      POINTEUR LPDPP.LSTIND
*
      INTEGER IMPR,IRET
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans makprm'
*STAT      CALL INMSTA(MSTAT,0)
C     - Construire la liste indexée suivante (P2ELDU) :
C         * Nombre de multiplets = nb points P1 de MELDUA ;
C         * chaque multiplet : numéro des éléments de MELDUA
C           contenant P1.
*      SEGPRT,MELPRI
*      SEGPRT,MELDUA
*      SEGPRT,KRSPGD
* In PONBL2 : SEGINI PONBLD
      CALL PONBL2(MELDUA,KRSPGD,NPODUA,
     $     PONBLD,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*      SEGPRT,PONBLD
*STAT      CALL PRMSTA('      sub. ponbl2',MSTAT,IMPR)
* In POELM2 : SEGINI P2ELDU
      CALL POELM2(MELDUA,KRSPGD,PONBLD,
     $     P2ELDU,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      SEGSUP PONBLD
*      SEGPRT,P2ELDU
*STAT      CALL PRMSTA('      sub. poelm2',MSTAT,IMPR)
C     - Construire la liste d'entiers suivante (PODPOP) :
C         * Nombre d'entiers = nb points P1 de MELDUA ;
C         * pour chaque P1 : nb. de points P2 de MELPRI avec lesquels il
C           a une liaison.
* In PONBPO : SEGINI PODPOP
      CALL PONBPO(P2ELDU,MELPRI,
     $     PODPOP,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*      SEGPRT,PODPOP
*STAT      CALL PRMSTA('      sub. ponbpo',MSTAT,IMPR)
C     - Construire la liste indexée suivante (LPDPP) :
C         * Nombre de multiplets = nb points P1 de MELDUA
C         * pour chaque P1 : numéro des points P2 de MELPRI avec
C           lesquels il a une liaison.
* In POPOIN : SEGINI LPDPP
      CALL POPOIN(P2ELDU,MELPRI,PODPOP,
     $     LPDPP,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      SEGSUP P2ELDU
      SEGSUP PODPOP
      IF (IMPR.GT.4) THEN
         WRITE(IOIMP,*) 'Liste des points duaux :'
         SEGPRT,KJSPGD
         WRITE(IOIMP,*) 'Liste indexée de correspondance ',
     $        'point dual-points primaux :'
         SEGPRT,LPDPP
      ENDIF
*STAT      CALL PRMSTA('      sub. popoin',MSTAT,IMPR)
C
C     - Initialisation et remplissage du profil de la matrice morse
C
      CALL MKPMOR(LPDPP,KJSPGD,KRINCP,KRINCD,
     $     KRSPGT,KMINCT,
     $     PMCOU,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      IF (IMPR.GT.4) THEN
         WRITE(IOIMP,*) 'Profil Morse non ordonné :'
         SEGPRT,PMCOU
      ENDIF
      SEGSUP LPDPP
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine makprm'
      RETURN
*
* End of subroutine MAKPRM
*
      END