Sources Esope | Cast3M

corinc
C CORINC    SOURCE    PV        05/12/01    21:15:02     5252
      SUBROUTINE CORINC(KRINCD,KRINCP,
     $     KRIDUN,LIPUN,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : CORINC
C PROJET      : Assemblage matrice élémentaire -> matrice Morse
C DESCRIPTION : Construction d'une liste indexée de correspondance :
C               (nom d'inconnue duale)->(noms d'inconnues primales
C               associé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          : IUNIQ, IREPER
C APPELE PAR       : MKPMOR
C***********************************************************************
C ENTREES            : KRINCD, KRINCP
C SORTIES            : KRIDUN, LIPUN
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 18/11/99, version initiale
C HISTORIQUE : v1, 18/11/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 SMLENTI
      INTEGER JG
      POINTEUR KRINCD.MLENTI
      POINTEUR KRINCP.MLENTI
      POINTEUR KRIDUN.MLENTI
      POINTEUR KRCDUN.MLENTI
*
* Includes perso
*
*
*     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
*-INC SLSTIND
      INTEGER NBM,NBTVAL
      POINTEUR LIPUN.LSTIND
*
      INTEGER IMPR,IRET
*
      INTEGER IDXCOU,INOZER
      INTEGER ICOMPD,IDUNIQ
      INTEGER NCOMPD,NDUNIQ,NCOMPP,NINCP
      LOGICAL LFOUND
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans corinc'
C On détermine le nombre de composantes primales distinctes
      SEGACT KRINCD
      NCOMPD=KRINCD.LECT(/1)
      JG=NCOMPD
      SEGINI KRIDUN
      CALL IUNIQ(KRINCD.LECT,NCOMPD,
     $     KRIDUN.LECT,NDUNIQ,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      JG=NDUNIQ
      SEGADJ,KRIDUN
* On construit la liste de repérage de KRINCD dans KRIDUN
      JG=NCOMPD
      SEGINI KRCDUN
      CALL IREPER(NCOMPD,NDUNIQ,
     $     KRINCD.LECT,KRIDUN.LECT,
     $     KRCDUN.LECT,
     $     IMPR,IRET)
C Pour chaque composante primale distincte, il faut 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)
      SEGACT KRINCP
      NCOMPP=KRINCP.LECT(/1)
      NBM=NDUNIQ
* Au maximum, chaque élément KRINCD est relié à tous les
* autres de KRINCP
      NBTVAL=NDUNIQ*NCOMPP
      SEGINI LIPUN
* On remplit la liste des index
      LIPUN.IDX(1)=1
      DO 1 IDUNIQ=1,NDUNIQ
         LIPUN.IDX(IDUNIQ+1)=LIPUN.IDX(IDUNIQ)+NCOMPP
 1    CONTINUE
* On construit la liste de correspondance contenant éventuellement
* des zéros que l'on supprimme après
      DO 3 ICOMPD=1,NCOMPD
         IDUNIQ=KRCDUN.LECT(ICOMPD)
         IDXCOU=LIPUN.IDX(IDUNIQ)
         NINCP=KRINCP.LECT(ICOMPD)
 5       CONTINUE
         LFOUND=(LIPUN.IVAL(IDXCOU).EQ.NINCP)
         IF (LIPUN.IVAL(IDXCOU).NE.0.AND.(.NOT.LFOUND)) THEN
            IDXCOU=IDXCOU+1
            GOTO 5
         ENDIF
         IF (.NOT.LFOUND) THEN
            LIPUN.IVAL(IDXCOU)=NINCP
         ENDIF
 3    CONTINUE
* On supprimme les zéros
      INOZER=1
      IDXCOU=1
      DO 7 IDUNIQ=1,NDUNIQ
 9       CONTINUE
         IF (IDXCOU.LE.LIPUN.IVAL(/1)) THEN
         IF (LIPUN.IVAL(IDXCOU).NE.0) THEN
             LIPUN.IVAL(INOZER)=LIPUN.IVAL(IDXCOU)
             INOZER=INOZER+1
             IDXCOU=IDXCOU+1
             GOTO 9
          ENDIF
          ENDIF
          IDXCOU=LIPUN.IDX(IDUNIQ+1)
          LIPUN.IDX(IDUNIQ+1)=INOZER
 7     CONTINUE
       NBTVAL=LIPUN.IDX(NDUNIQ+1)-1
       SEGADJ,LIPUN
       SEGDES LIPUN
       SEGDES KRINCP
       SEGSUP KRCDUN
       SEGDES KRIDUN
       SEGDES KRINCD
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine corinc'
      RETURN
*
* End of subroutine CORINC
*
      END