Sources Esope | Cast3M

crechp
C CRECHP    SOURCE    CB215821  25/04/23    21:15:10     12247          
      SUBROUTINE CRECHP(KTRAV,KCHPOI)
C
C
C
C ********   CE SUBROUTINE SERT A CREER UN CHAMP POINT A PARTIR
C ********   D'UN SEGMENT MTRAV.
C
C ********   INCO(NNIN) CONTIENT LE NOMS DES NNIN INCONNUES DIFFERENTES.
C
C ********   BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DU CHAMP POUR
C ********   LE JEME NOEUD DU TABLEAU IGEO.
C
C ********   IBIN(I,J)=1 OU 0. 1 INDIQUE QUE LA I EME INCONNUE DU CHAMP
C ********   EXISTE POUR LE J EME NOEUD DU TABLEAU IGEO.
C
C ********   IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR
C ********   REFERENCER LE IEME NOEUD
C
C ********   NHAR(I)  EST LE NUMERO D'HARMONIQUE SI CALCUL AXI OU
C ********   SIGNIFIE CONTRAINTE PLANE,DEFORMATION PLANE OU DEF PLAN GEN
C
C ********  ATTENTION ATTENTION ATTENTION IL EXISTE UNE VARIABLE
C ********  POUVANT DEPENDRE DE LA MACHINE. NN25 EST SUPPOSE SUFFISAMENT
C ********  PETIT POUR QUE 2**NN25 SOIT UN ENTIER POSSIBLE.
C
C
C *** POUR PLUS DE RENSEIGNEMENTS VOIR CHARRAS.
C
C
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMCOORD
-INC SMELEME
-INC TMTRAV
 
      SEGMENT/NTRAV/(IDEJ(NNIN),INO(NNNOE),IBINN(NNNOE,N25),IVA(NNIN),
     1 ICO(NNNOE))
      SEGMENT,ILO(0)
      SEGMENT,IPE(0)
      NN25=25
      MTRAV=KTRAV
      if (mtrav .lt.0) call erreur(5)
      NNIN=INCO(/2)
      NNNOE=IBIN(/2)
      N25=(NNIN+NN25-1)/NN25
 
      CALL oooprl(1)
      SEGINI,NTRAV,ILO,IPE
      CALL oooprl(0)
C
C  ****  CREATION DU TABLEAU IBINN. CE TABLEAU PERMET DE REGROUPER
C  ****  LES INFORMATIONS DE IBIN DE MANIERE A TESTER RAPIDEMENT
C  ****  SI 2 NOEUDS ONT LES MEMES INCONNUES.
C
      J=0
      K=1
      IO=1
      DO 49 I=1,NNIN
      J=J+1
      IVA(I)=IO
      IO=IO*2
      IF(J.LT.NN25)  GO TO 49
      IO=1
      J=0
  49  CONTINUE
      DO 51 I=1,NNNOE
      K=0
      DO 510 L=1,N25
      L1=1+(L-1)*NN25
      L2=L*NN25
      L2=MIN(L2,NNIN)
      IAFS=0
      DO 52 J=L1,L2
      IF(IBIN(J,I).EQ.0)  GO TO 52
      K=L
      JJ=J-(L-1)*NN25
      IAFS=IAFS+IVA(JJ)
   52 CONTINUE
      IBINN(I,L)=IAFS
  510 CONTINUE
      ICO(I)=K
   51 CONTINUE
C
C  ****  CLASSEMENT DES NOEUDS PAR TYPES. ON REMPLIT LE TABLEAU INO.
C  ****  DEUX NOEUDS ONT LE MEME TYPE S'ILS ONT LES MEMES INCONNUES.
C  ****  INO(I)=J VEUT DIRE QUE LE I EME NOEUD EST DE TYPE J.
C  ****  N DONNE LE NOMBRE DE TYPES DE NOEUD DIFFERENTS.
C
      N=0
      NTROUV=0
      DO 53 IDEB=1,NNNOE
      IF(ICO(IDEB).NE.0) GO TO 54
   53 CONTINUE
      GO TO 540
   54 CONTINUE
    3 CONTINUE
      N=N+1
      IPE(**)=IDEB
      ITES=IDEB
      KK=0
      DO 1 I=IDEB,NNNOE
      DO 2 J=1,N25
      IF(IBINN(I,J).NE.IBINN(ITES,J)) GO TO 1
   2  CONTINUE
      KK=KK+1
      INO(I)=N
      ICO(I)=0
   1  CONTINUE
      ILO(**)=KK
      NTROUV=NTROUV+KK
      IF(NTROUV.NE.NNNOE) THEN
      DO 4 IDEB=1,NNNOE
      IF(ICO(IDEB).NE.0)  GO TO 3
    4 CONTINUE
      ENDIF
C
C  ****  ON CONNAIT LE NOMBRE DE SOUS CHAMPS
C  ****  ON INITIALISE LE SEGMENT  MCHPOIN
C
C
  540 CONTINUE
      NSOUPO=N
      NAT=1
      NBSOUS=0
      NBREF=0
      NBNN=1
 
C     Creation du resultat par paquets
      CALL oooprl(1)
      SEGINI,MCHPOI
      DO I=1,NSOUPO
        IHK=IPE(I)
        NC=0
        DO 21 JK=1,NNIN
          IF(IBIN(JK,IHK).EQ.0)  GO TO 21
          NC=NC+1
          IDEJ(NC)=JK
   21   CONTINUE
        SEGINI,MSOUPO
        IPCHP(I)=MSOUPO
 
        NBELEM=ILO(I)
        N=NBELEM
        SEGINI,MPOVAL,MELEME
        IGEOC=MELEME
        IPOVAL=MPOVAL
      ENDDO
      CALL oooprl(0)
 
      IFOPOI=IFOUR
      JATTRI(1) = 0
      MTYPOI='        '
      MOCHDE='            CHPOINT CREE PAR CRECHP'
C
C  ****  ON VA FABRIQUER LES SEGMENTS MSOUPO POUR LES REMPLIR IL FAUT
C  **** CONNAITRE LES INCONNUES DU SOUS CHAMPS ET L'OBJET GEOMETRIQUE
C  ****  SUPPORT
C
      IF(NSOUPO.EQ.0) THEN
        KCHPOI=MCHPOI
        SEGSUP,NTRAV,ILO,IPE
        RETURN
      ENDIF
 
      DO 100 I=1,NSOUPO
C
C  **** ON CHERCHE D'ABORD LA LISTE DES INCONNUES A PARTIR DE LA
C  **** VALEUR DE IBINN ET ON REMPLIT NOCOMP
C
      IHK=IPE(I)
      NC=0
      DO 20 JK=1,NNIN
        IF(IBIN(JK,IHK).EQ.0)  GO TO 20
        NC=NC+1
        IDEJ(NC)=JK
   20 CONTINUE
      MSOUPO=IPCHP(I)
      DO 14 J=1,NC
        NOHARM(J)=NHAR(IDEJ(J))
        NOCOMP(J)=INCO(IDEJ(J))
   14 CONTINUE
C
C  ****  ON CHERCHE COMBIEN DE NOEUD DANS L'OBJET MELEME,ON LE CREE
C
      NBELEM=ILO(I)
      N=NBELEM
      MPOVAL=IPOVAL
      MELEME=IGEOC
      ITYPEL=1
      IC=0
      DO 16 J=1,NNNOE
        IF(INO(J).NE.I) GOTO 16
        IC=IC+1
        NUM(1,IC)=IGEO(J)
        DO 18 K=1,NC
          IO=IDEJ(K)
          VPOCHA(IC,K)=BB(IO,J)
   18   CONTINUE
   16 CONTINUE
 
      call crech1(meleme,1)
      IGEOC=MELEME
 
 100  CONTINUE
      SEGSUP,ILO,IPE,NTRAV
      KCHPOI=MCHPOI
 
      END