Esope source files

   1 : C CORINC    SOURCE    PV        05/12/01    21:15:02     5252           
   2 :       SUBROUTINE CORINC(KRINCD,KRINCP,
   3 :      $     KRIDUN,LIPUN,
   4 :      $     IMPR,IRET)
   5 :       IMPLICIT INTEGER(I-N)
   6 :       IMPLICIT REAL*8 (A-H,O-Z)
   7 : C***********************************************************************
   8 : C NOM         : CORINC
   9 : C PROJET      : Assemblage matrice élémentaire -> matrice Morse
  10 : C DESCRIPTION : Construction d'une liste indexée de correspondance :
  11 : C               (nom d'inconnue duale)->(noms d'inconnues primales
  12 : C               associées) 
  13 : C
  14 : C LANGAGE     : ESOPE
  15 : C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  16 : C               mél : gounand@semt2.smts.cea.fr
  17 : C***********************************************************************
  18 : C APPELES          : IUNIQ, IREPER
  19 : C APPELE PAR       : MKPMOR
  20 : C***********************************************************************
  21 : C ENTREES            : KRINCD, KRINCP
  22 : C SORTIES            : KRIDUN, LIPUN
  23 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  24 : C***********************************************************************
  25 : C VERSION    : v1, 18/11/99, version initiale
  26 : C HISTORIQUE : v1, 18/11/99, création
  27 : C HISTORIQUE :
  28 : C HISTORIQUE :
  29 : C***********************************************************************
  30 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  31 : C en cas de modification de ce sous-programme afin de faciliter
  32 : C la maintenance !
  33 : C***********************************************************************
  34 : -INC CCOPTIO
  35 : -INC SMLENTI
  36 :       INTEGER JG
  37 :       POINTEUR KRINCD.MLENTI
  38 :       POINTEUR KRINCP.MLENTI
  39 :       POINTEUR KRIDUN.MLENTI
  40 :       POINTEUR KRCDUN.MLENTI
  41 : *
  42 : * Includes perso
  43 : *
  44 : *
  45 : *     Segment LSTIND (liste séquentielle indexée)
  46 : *
  47 :       SEGMENT LSTIND
  48 :       INTEGER IDX(NBM+1)
  49 :       INTEGER IVAL(NBTVAL)
  50 :       ENDSEGMENT
  51 : *
  52 : *     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  53 : *
  54 : *     NBM      : NOMBRE DE MULTIPLETS
  55 : *     NBTVAL   : NOMBRE TOTAL DE VALEURS 
  56 : *     IDX(I)   : INDICE DE LA PREMIERE VALEUR DU IEME 
  57 : *                MULTIPLET DANS LE TABLEAU IVAL
  58 : *     IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  59 : *-INC SLSTIND
  60 :       INTEGER NBM,NBTVAL
  61 :       POINTEUR LIPUN.LSTIND
  62 : *
  63 :       INTEGER IMPR,IRET
  64 : *
  65 :       INTEGER IDXCOU,INOZER
  66 :       INTEGER ICOMPD,IDUNIQ
  67 :       INTEGER NCOMPD,NDUNIQ,NCOMPP,NINCP
  68 :       LOGICAL LFOUND
  69 : *     
  70 : * Executable statements
  71 : *
  72 :       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans corinc'
  73 : C On détermine le nombre de composantes primales distinctes
  74 :       SEGACT KRINCD
  75 :       NCOMPD=KRINCD.LECT(/1)
  76 :       JG=NCOMPD
  77 :       SEGINI KRIDUN
  77 :       CALL IUNIQ(KRINCD.LECT,NCOMPD,
  78 :      $     KRIDUN.LECT,NDUNIQ,
  79 :      $     IMPR,IRET)
  80 :       IF (IRET.NE.0) GOTO 9999
  81 :       JG=NDUNIQ
  82 :       SEGADJ,KRIDUN
  83 : * On construit la liste de repérage de KRINCD dans KRIDUN
  84 :       JG=NCOMPD
  85 :       SEGINI KRCDUN
  85 :       CALL IREPER(NCOMPD,NDUNIQ,
  86 :      $     KRINCD.LECT,KRIDUN.LECT,
  87 :      $     KRCDUN.LECT,
  88 :      $     IMPR,IRET)
  89 : C Pour chaque composante primale distincte, il faut déterminer
  90 : C avec quels composantes duales distinctes il est relié :
  91 : C Par exemple, si on a :
  92 : C      KRINCD = 1  1  1  2 
  93 : C      KRINCP = 2  2  3  4
  94 : C On a :    KRIDUN =  1     2
  95 : C On veut :  LIPUN = (2 3) (4) (c'est une liste indexée)
  96 :       SEGACT KRINCP
  97 :       NCOMPP=KRINCP.LECT(/1)
  98 :       NBM=NDUNIQ
  99 : * Au maximum, chaque élément KRINCD est relié à tous les 
 100 : * autres de KRINCP
 101 :       NBTVAL=NDUNIQ*NCOMPP
 102 :       SEGINI LIPUN
 103 : * On remplit la liste des index
 104 :       LIPUN.IDX(1)=1
 105 :       DO 1 IDUNIQ=1,NDUNIQ
 106 :          LIPUN.IDX(IDUNIQ+1)=LIPUN.IDX(IDUNIQ)+NCOMPP
 107 :  1    CONTINUE
 108 : * On construit la liste de correspondance contenant éventuellement
 109 : * des zéros que l'on supprimme après
 110 :       DO 3 ICOMPD=1,NCOMPD
 111 :          IDUNIQ=KRCDUN.LECT(ICOMPD)
 112 :          IDXCOU=LIPUN.IDX(IDUNIQ)
 113 :          NINCP=KRINCP.LECT(ICOMPD)
 114 :  5       CONTINUE
 115 :          LFOUND=(LIPUN.IVAL(IDXCOU).EQ.NINCP)
 116 :          IF (LIPUN.IVAL(IDXCOU).NE.0.AND.(.NOT.LFOUND)) THEN
 117 :             IDXCOU=IDXCOU+1
 118 :             GOTO 5
 119 :          ENDIF
 120 :          IF (.NOT.LFOUND) THEN
 121 :             LIPUN.IVAL(IDXCOU)=NINCP
 122 :          ENDIF
 123 :  3    CONTINUE
 124 : * On supprimme les zéros
 125 :       INOZER=1
 126 :       IDXCOU=1
 127 :       DO 7 IDUNIQ=1,NDUNIQ
 128 :  9       CONTINUE
 129 :          IF (IDXCOU.LE.LIPUN.IVAL(/1)) THEN
 130 :          IF (LIPUN.IVAL(IDXCOU).NE.0) THEN
 131 :              LIPUN.IVAL(INOZER)=LIPUN.IVAL(IDXCOU)
 132 :              INOZER=INOZER+1
 133 :              IDXCOU=IDXCOU+1
 134 :              GOTO 9
 135 :           ENDIF
 136 :           ENDIF
 137 :           IDXCOU=LIPUN.IDX(IDUNIQ+1)
 138 :           LIPUN.IDX(IDUNIQ+1)=INOZER
 139 :  7     CONTINUE
 140 :        NBTVAL=LIPUN.IDX(NDUNIQ+1)-1
 141 :        SEGADJ,LIPUN
 142 :        SEGDES LIPUN
 143 :        SEGDES KRINCP
 144 :        SEGSUP KRCDUN
 145 :        SEGDES KRIDUN
 146 :        SEGDES KRINCD
 147 : *
 148 : * Normal termination
 149 : *
 150 :       IRET=0
 151 :       RETURN
 152 : *
 153 : * Format handling
 154 : *
 155 : *
 156 : * Error handling
 157 : *
 158 :  9999 CONTINUE
 159 :       IRET=1
 160 :       WRITE(IOIMP,*) 'An error was detected in subroutine corinc'
 161 :       RETURN
 162 : *
 163 : * End of subroutine CORINC
 164 : *
 165 :       END
 166 : 
 167 :  
 168 :  
 169 :  
 170 :