Esope source files

   1 : C MELAND    SOURCE    CHAT      05/01/13    01:41:54     5004           
   2 :       SUBROUTINE MELAND(GPMELS,
   3 :      $     MAICOM,
   4 :      $     IMPR,IRET)
   5 :       IMPLICIT INTEGER(I-N)
   6 :       IMPLICIT REAL*8 (A-H,O-Z)
   7 : C***********************************************************************
   8 : C NOM         : MELAND
   9 : C DESCRIPTION : Renvoie le maillage de points (POI1) MAICOM des
  10 : C               points appartenant à tous les maillages de gpmels.
  11 : C
  12 : C LANGAGE     : ESOPE
  13 : C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  14 : C               mél : gounand@semt2.smts.cea.fr
  15 : C***********************************************************************
  16 : C APPELES          : -
  17 : C APPELE PAR       : MELCOM
  18 : C***********************************************************************
  19 : C ENTREES            : GPMELS
  20 : C SORTIES            : MAICOM
  21 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  22 : C***********************************************************************
  23 : C VERSION    : v1, 12/05/99, version initiale
  24 : C HISTORIQUE : v1, 12/05/99, création
  25 : C HISTORIQUE :
  26 : C HISTORIQUE :
  27 : C***********************************************************************
  28 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  29 : C en cas de modification de ce sous-programme afin de faciliter
  30 : C la maintenance !
  31 : C***********************************************************************
  32 : -INC CCOPTIO
  33 : -INC SMCOORD
  34 : -INC SMELEME
  35 :       POINTEUR MELCOU.MELEME
  36 :       POINTEUR SOUMEL.MELEME
  37 :       INTEGER NBELEM,NBNN,NBREF,NBSOUS
  38 :       POINTEUR MAICOM.MELEME
  39 : -INC SMLENTI
  40 :       INTEGER JG
  41 :       POINTEUR IWORK.MLENTI
  42 : *
  43 : * Includes persos
  44 : *
  45 :       SEGMENT MELS
  46 :       POINTEUR LISMEL(NBMEL).MELEME
  47 :       ENDSEGMENT
  48 :       POINTEUR GPMELS.MELS
  49 : *
  50 :       INTEGER IMPR,IRET
  51 : *
  52 :       LOGICAL LSAME
  53 :       INTEGER BEGI,LAST,ILAST,IPREC,LDG,ILDG,NUMNO
  54 :       INTEGER IELEM,IPOEL,ISOUS,IMEL
  55 :       INTEGER NELEM,NPOEL,NSOUS,NMEL
  56 : *     
  57 : * Executable statements
  58 : *
  59 :       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans meland.eso' 
  60 :       SEGACT GPMELS
  61 :       NMEL=GPMELS.LISMEL(/1)
  62 :       IF (NMEL.LE.0) THEN
  63 :          WRITE(IOIMP,*) 'Nombre de MELEMEs négatif ou nul'
  64 :          GOTO 9999
  65 :       ENDIF
  66 : * On cherche le cas évident :
  67 : * - Maillage tous identiques de POI1
  68 :       MELCOU=GPMELS.LISMEL(1)
  69 :       SEGACT MELCOU
  70 :       LSAME=.FALSE.
  71 :       IF (MELCOU.ITYPEL.EQ.1) THEN
  72 :          LSAME=.TRUE.
  73 :          DO 1 IMEL=2,NMEL
  74 :             IF (GPMELS.LISMEL(IMEL).NE.MELCOU) THEN
  75 :                LSAME=.FALSE.
  76 :             ENDIF
  77 :  1       CONTINUE
  78 :       ENDIF
  79 :       SEGDES MELCOU
  80 :       IF (LSAME) THEN 
  81 :          SEGINI,MAICOM=MELCOU
  82 :          SEGDES MAICOM
  83 :       ELSE
  84 : * - On construit la liste chaînée avec le premier maillage
  85 :          JG=XCOOR(/1)/(IDIM+1)
  86 :          SEGINI IWORK
  87 : *   degré, fin de la liste chaînée
  88 :          LDG=0
  89 :          BEGI=XCOOR(/1)/(IDIM+1)+1
  90 :          LAST=BEGI
  91 :          MELCOU=GPMELS.LISMEL(1)
  92 :          SEGACT MELCOU
  93 :          NSOUS=MELCOU.LISOUS(/1)
  94 :          DO 3 ISOUS=1,MAX(1,NSOUS)
  95 :             IF (NSOUS.EQ.0) THEN
  96 :                SOUMEL=MELCOU
  97 :             ELSE
  98 :                SOUMEL=MELCOU.LISOUS(ISOUS)
  99 :                SEGACT SOUMEL
 100 :             ENDIF
 101 :             NPOEL=SOUMEL.NUM(/1)
 102 :             NELEM=SOUMEL.NUM(/2)
 103 :             DO 32 IELEM=1,NELEM
 104 :                DO 322 IPOEL=1,NPOEL
 105 :                   NUMNO=SOUMEL.NUM(IPOEL,IELEM)
 106 :                   IF (IWORK.LECT(NUMNO).EQ.0) THEN
 107 :                      LDG=LDG+1
 108 :                      IWORK.LECT(NUMNO)=LAST
 109 :                      LAST=NUMNO
 110 :                   ENDIF
 111 :  322           CONTINUE
 112 :  32         CONTINUE
 113 :             IF (NSOUS.NE.0) THEN
 114 :                SEGDES SOUMEL
 115 :             ENDIF
 116 :  3       CONTINUE
 117 :          SEGDES MELCOU
 118 : * - On réduit la liste chaînée des points des autres maillages 
 119 : *   qui ne sont pas déjà dedans
 120 : *COMM         write(ioimp,*) 'nmel=',nmel
 121 :          DO 5 IMEL=2,NMEL
 122 : *COMM            write(ioimp,*) 'last,ldg,imel',LAST,LDG,IMEL
 123 : *COMM            SEGPRT,IWORK
 124 : * On attribue le signe - à tous les points de la liste chaînée
 125 :             NUMNO=LAST
 126 :             DO 52 ILDG=1,LDG
 127 :                IPREC=IWORK.LECT(NUMNO)
 128 :                IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
 129 :                NUMNO=IPREC
 130 :  52         CONTINUE
 131 : *COMM            write(ioimp,*) 'négativation'
 132 : *COMM            SEGPRT,IWORK
 133 :             MELCOU=GPMELS.LISMEL(IMEL)
 134 : * On attribue le signe + aux points de la liste chaînée
 135 : * qui sont dans le IMEL ième maillage
 136 :             SEGACT MELCOU
 137 :             NSOUS=MELCOU.LISOUS(/1)
 138 :             DO 54 ISOUS=1,MAX(1,NSOUS)
 139 :                IF (NSOUS.EQ.0) THEN
 140 :                   SOUMEL=MELCOU
 141 :                ELSE
 142 :                   SOUMEL=MELCOU.LISOUS(ISOUS)
 143 :                   SEGACT SOUMEL
 144 :                ENDIF
 145 :                NPOEL=SOUMEL.NUM(/1)
 146 :                NELEM=SOUMEL.NUM(/2)
 147 :                DO 542 IELEM=1,NELEM
 148 :                   DO 5422 IPOEL=1,NPOEL
 149 :                      NUMNO=SOUMEL.NUM(IPOEL,IELEM)
 150 :                      IF (IWORK.LECT(NUMNO).LT.0) THEN
 151 :                         IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
 152 :                      ENDIF
 153 :  5422             CONTINUE
 154 :  542           CONTINUE
 155 :                IF (NSOUS.NE.0) THEN
 156 :                   SEGDES SOUMEL
 157 :                ENDIF
 158 :  54         CONTINUE
 159 :             SEGDES MELCOU
 160 : *COMM            write(ioimp,*) 'positivation'
 161 : *COMM            SEGPRT,IWORK
 162 : * On nettoie la liste chaînée des points qui sont restés 
 163 : * avec le signe négatif
 164 : *
 165 : * D'abord, on cherche la fin de ce qui sera la nouvelle liste
 166 : *   If (LAST.EQ.BEGI), la liste résultat est vide
 167 :             IF (LAST.NE.BEGI) THEN
 168 :                NUMNO=LAST
 169 :  56            CONTINUE
 170 :                IPREC=IWORK.LECT(NUMNO)
 171 :                IF (IPREC.LT.0) THEN
 172 :                   LDG=LDG-1
 173 :                   IWORK.LECT(NUMNO)=0
 174 :                   NUMNO=-IPREC
 175 :                   IF (NUMNO.NE.BEGI) THEN
 176 :                      GOTO 56
 177 :                   ENDIF
 178 :                ENDIF
 179 :                LAST=NUMNO
 180 :             ENDIF
 181 : *COMM            write(ioimp,*) 'Fin de la liste=',LAST
 182 : * Une fois obtenue la fin de la liste résultat, on continue
 183 : *   If (LAST.EQ.BEGI), la liste résultat est vide
 184 :             IF (LAST.NE.BEGI) THEN
 185 :                ILAST=LAST
 186 :                NUMNO=LAST
 187 : *   IPREC est forcément positif sinon, LAST n'aurait pas la bonne valeur
 188 :                IPREC=IWORK.LECT(NUMNO)
 189 :                NUMNO=IPREC
 190 : *COMM               write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
 191 :                IF (NUMNO.NE.BEGI) THEN
 192 :  58               CONTINUE
 193 :                   IPREC=IWORK.LECT(NUMNO)
 194 : *COMM                  write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
 195 :                   IF (IPREC.LT.0) THEN
 196 :                      LDG=LDG-1
 197 :                      IWORK.LECT(NUMNO)=0
 198 :                      NUMNO=-IPREC
 199 :                   ELSE
 200 :                      IWORK.LECT(ILAST)=NUMNO
 201 :                      ILAST=NUMNO
 202 :                      NUMNO=IPREC
 203 :                   ENDIF
 204 :                   IF (NUMNO.NE.BEGI) THEN
 205 :                      GOTO 58
 206 :                   ENDIF
 207 :                ENDIF
 208 :                IWORK.LECT(ILAST)=BEGI
 209 : *COMM               write(ioimp,*) 'nettoyage'
 210 : *COMM               SEGPRT,IWORK
 211 :             ENDIF
 212 :  5       CONTINUE
 213 : * Créer le maillage de points correspondant à la liste chaînée
 214 :          NBNN=1
 215 :          NBELEM=LDG
 216 :          NBSOUS=0
 217 :          NBREF=0
 218 :          SEGINI MAICOM
 219 :          MAICOM.ITYPEL=1
 220 :          NUMNO=LAST
 221 :          DO 7 ILDG=1,LDG
 222 :             IPREC=IWORK.LECT(NUMNO)
 223 :             MAICOM.NUM(1,ILDG)=NUMNO
 224 :             NUMNO=IPREC
 225 :  7       CONTINUE
 226 :          SEGDES MAICOM
 227 :          SEGSUP IWORK
 228 :       ENDIF
 229 :       SEGDES GPMELS
 230 :       IF (IMPR.GT.2) THEN
 231 :          WRITE(IOIMP,*) 'On a créé MAICOM=',MAICOM
 232 :          IF (IMPR.GT.3) THEN
 233 :             SEGPRT,MAICOM
 234 :          ENDIF
 235 :       ENDIF
 236 : *
 237 : * Normal termination
 238 : *
 239 :       IRET=0
 240 :       RETURN
 241 : *
 242 : * Format handling
 243 : *
 244 : *
 245 : * Error handling
 246 : *
 247 :  9999 CONTINUE
 248 :       IRET=1
 249 :       WRITE(IOIMP,*) 'An error was detected in subroutine meland'
 250 :       RETURN
 251 : *
 252 : * End of subroutine MELAND
 253 : *
 254 :       END
 255 : 
 256 :  
 257 :  
 258 :