Esope source files

   1 : C KCHA0     SOURCE    CHAT      05/01/13    00:52:35     5004           
   2 :       SUBROUTINE KCHA0(ICHP1,IPSG,NBCOMP,NOMTOT,MTRAV,ICCPR)
   3 : C-----------------------------------------------------------------------
   4 : C  Création du segment de travail MTRAV (et du segment de redirection)
   5 : C  associé au champoint ICHP1 sur le maillage de référence IPSG.
   6 : C  Le segment de travail contient au plus les composantes contenues
   7 : C  dans le tableau NOMTOT (si NBCOMP est différent de 0) .
   8 : C-----------------------------------------------------------------------
   9 : C
  10 : C---------------------------
  11 : C Parametres Entree/Sortie :
  12 : C---------------------------
  13 : C
  14 : C E/  ICHP1  : Champoint
  15 : C E/  IPSG   : Maillage de référence, en général de type POI1
  16 : C E/  NBCOMP : Nombre de composantes à extraire (toutes  NBCOMP = 0)
  17 : C E/  NOMTOT : Tableau des noms des composantes à extraire
  18 : C S/  MTRAV  : Segment de travail
  19 : C S/  ICCPR  : Segment de redirection (ICPR inverse de IGEO dans MTRAV)
  20 : C
  21 : C-------------------------------------
  22 : C Tableaux du segment de redirection :
  23 : C-------------------------------------
  24 : C
  25 : C  ICPR(I)=J : Le noeud I a le numero J dans le MELEME des faces
  26 : C  NNGOT     : Nombre de noeuds total du domaine
  27 : C
  28 : C-----------------------------------------------------------------------
  29 : C
  30 : C Langage : ESOPE + FORTRAN77
  31 : C
  32 : C Auteurs : L. DADA
  33 : C
  34 : C-----------------------------------------------------------------------
  35 :       IMPLICIT INTEGER(I-N)
  36 :       IMPLICIT REAL*8 (A-H,O-Z)
  37 :       CHARACTER*4 NOMTOT(*)
  38 : C
  39 : -INC CCOPTIO
  40 : -INC SMELEME
  41 : -INC SMCHPOI
  42 : -INC SMCOORD
  43 : -INC TMTRAV
  44 : C
  45 :       SEGMENT ICCPR
  46 :          INTEGER ICPR(NNGOT)
  47 :       ENDSEGMENT
  48 : C
  49 : C- Transforme le maillage en POI1 si maillage quelconque
  50 : C- Le maillage POI1 de pointeur IPT1 est actif au retour de CHANGE
  51 : C
  52 :       IPT1 = IPSG
  53 :       SEGACT IPT1
  54 : C PPw NBSOUS = LISOUS(/1)
  55 :       NBSOUS = IPT1.LISOUS(/1)
  56 : C PPw IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
  57 :       IF ((NBSOUS.NE.0).OR.(IPT1.ITYPEL.NE.1)) THEN
  58 : 
  58 :          CALL CHANGE(IPT1,1)
  59 :          IF (IERR.NE.0) RETURN
  60 :       ENDIF
  61 : C
  62 : C - Création du tableau ICPR pour le maillage IPT1
  63 : C
  64 :       NNGOT  = XCOOR(/1)/(IDIM+1)
  65 :       SEGINI ICCPR
  66 : C
  67 :       NNNOE = IPT1.NUM(/2)
  68 :       IK    = 0
  69 :       DO 10 I2=1,NNNOE
  70 :          K = IPT1.NUM(1,I2)
  71 :          IF (ICPR(K).EQ.0) THEN
  72 :             IK      = IK + 1
  73 :             ICPR(K) = IK
  74 :          ENDIF
  75 :  10   CONTINUE
  76 :       SEGDES IPT1
  77 : C
  78 : C - Récupération du nombre de composantes de ICHP1
  79 : C
  80 :       MCHPOI = ICHP1
  81 :       SEGACT MCHPOI
  82 :       NSOUPO = IPCHP(/1)
  83 :       NNIN   = 0
  84 :       DO 20 I=1,NSOUPO
  85 :          MSOUPO = IPCHP(I)
  86 :          SEGACT MSOUPO
  87 :          NNIN   = NNIN + NOCOMP(/2)
  88 :  20   CONTINUE
  89 : C
  90 : C - Création et remplissage de MTRAV
  91 : C - Balayage des partitions de ICHP1, utilisation du tableau ICPR
  92 : C - Extraction des composantes uniquement contenues dans NOMTOT
  93 : C - si NBCOMP.NE.0
  94 : C
  95 :       SEGINI MTRAV
  96 : C
  97 : C - Nombre de composantes véritablement dans MTRAV :
  98 : C
  99 :       NBIN = 0
 100 : C
 101 :       DO 30 I=1,NSOUPO
 102 :          MSOUPO = IPCHP(I)
 103 :          NC     = NOCOMP(/2)
 104 :          MPOVAL = IPOVAL
 105 :          SEGACT MPOVAL
 106 :          MELEME = IGEOC
 107 :          SEGACT MELEME
 108 :          NBELEM = NUM(/2)
 109 :          DO 50 ICOMP=1,NC
 110 :            IF (NBCOMP.NE.0) THEN
 110 :               CALL PLACE(NOMTOT,NBCOMP,IPEXT,NOCOMP(ICOMP))
 111 :            ENDIF
 112 :            IF ((NBCOMP.EQ.0).OR.(IPEXT.NE.0)) THEN
 112 :               CALL PLACE(INCO,NBIN,IPOS,NOCOMP(ICOMP))
 113 :               IF ((IPOS.EQ.0).OR.(NHAR(IPOS).NE.NOHARM(ICOMP))) THEN
 114 :                  NBIN = NBIN + 1
 115 :                  INCO(NBIN) = NOCOMP(ICOMP)
 116 :                  NHAR(NBIN) = NOHARM(ICOMP)
 117 :                  IPOS = NBIN
 118 :               ENDIF
 119 :               DO 40 J=1,NBELEM
 120 :                  K  = NUM(1,J)
 121 :                  IK = ICPR(K)
 122 :                  IF (IK.NE.0) THEN
 123 :                     IGEO(IK) = K
 124 :                     IBIN(IPOS,IK) = 1
 125 :                     BB(IPOS,IK)   = VPOCHA(J,ICOMP)
 126 :                  ENDIF
 127 :  40           CONTINUE
 128 :             ENDIF
 129 :  
 130 :  50      CONTINUE
 131 :          SEGDES MELEME
 132 :          SEGDES MPOVAL
 133 :          SEGDES MSOUPO
 134 :  30   CONTINUE
 135 :       SEGDES MCHPOI
 136 :  
 137 : C
 138 :       NNIN = NBIN
 139 :       SEGADJ MTRAV
 140 : C
 141 : C - Test si toutes les composantes que l'on voulait extraire sont
 142 : C - bien dans le segment de travail
 143 : C
 144 :       DO 60 I=1,NBCOMP
 144 :          CALL PLACE(INCO,NNIN,IPEXT,NOMTOT(I))
 145 :          IF (IPEXT.EQ.0) THEN
 146 :             MOTERR(1:4) = NOMTOT(I)
 146 :             CALL ERREUR(197)
 147 :             SEGDES MTRAV,ICCPR
 148 :             RETURN
 149 :          ENDIF
 150 :  60   CONTINUE
 151 :  
 152 :       SEGDES MTRAV
 153 :       SEGDES ICCPR
 154 : C
 155 :       END
 156 :  
 157 :  
 158 :