Sources Esope | Cast3M

h8rcgi
C H8RCGI    SOURCE    CB215821  26/10/26    21:15:34     12682          
      SUBROUTINE H8RCGI(IGR11,NBLG11,NBCO11,
     >            IGR22,NBLG22,NBCO22,COORD,NBCOOR,IDIMC,NBCOUC,RAISON,
     >            NBLIG3,NBCOL3,NBRAN3,IARETE,NARETE,
     >            ITVL,NITMAX,
     >            ITRNOE,NBNMAX,NBE,NBP,
     >            NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr)
C     **********************************************************************
C       OBJET H8RCGI : MAILLAGE H8 S'APPUYANT 2 GRILLES IDENTIQUES
C
C       ON GENERE UNE GRILLE 3D QUI S'APPUIT INITIALEMENT SUR LES GRILLES
C       IGR11 ET IGR22 PUIS ON APPLIQUE DES "COUPER-COLLER" DONNES (NARETE)
C
C     EN ENTREE   :
C
C       IGR11,NBLIG11,NBCOL11 : LA PREMIERE GRILLE
C       IGR22,NBLIG22,NBCOL22 : LA DEUXIEME GRILLE
C       COORD,NBCOOR,IDIMC    : POSITION DES NOEUDS
C
C       NBCOUC                : NOMBRE DE COUCHES SUPPLEMENTAIRES
C                               (PAR DEFAUT 1 SEULE COUCHE)
C       NBLIG3,NBCOL3,NBRAN3 : GRILLE 3D DE RACCORD
C       IARETE,NARETE        : INDICE ET CARDINAUX DES RANGEES A COUPER
C                              A ET RECOLLER
C
C       ITVL    : TABLEAU D'ENTIERS POUR LES CALCULS
C       NITMAX  : TAILLE DE ITVL, LA PLACE NECESSAIRE EST DE
C                 NBLIG3*NBCOL3*NBRAN3 AU MINIMUM, SI ICOMPR= 0
C                 SINON IL FAUT AJOUTER : NBLIG3*NBCOL3*(NBRAN3-2) + NBCOOR
C
C       ITRNOE : TABLEAU DES ELEMENTS (A REMPLIR)
C       NBEMAX : NOMBRE MAXIMUM D'ELEMENTS
C       NBPMAX : NOMBRE MAXIMUM DE NOEUDS (LIE A LA TAILLE DE COORD)
C
C       ICOMPR  : FLAG DE COMPRESSION
C       ICOMPR = 0 LES NOEUDS ISOLES NE SONT PAS SUPPRIMES
C                  LES ELEMENTS NULS "   "    "    "
C
C     EN SORTIE   :
C
C       ITRNOE,NBNMAX,ITRTRI,NBE,NBP : LE MAILLAGE RESULTANT
C       iarr     : CODE D'ERREUR -1 SI DONNEES INCORRECTES
C                                -2 SI TABLEAUX INSUFFISANTS
C
C     REMARQUE : L'ALGORITHME GENERE LES NOEUDS D'UNE GRILLE COMPLETE
C                APRES LE COUPER-COLLER CERTAIN NOEUDS DEVIENDRONT ISOLES
C                ET CERTAIN ELEMENTS SERONT NON VALIDES (NULS).
C                LE FLAG "ICOMPR" PERMET DE LES SUPPRIMER
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER IGR11(*),NBLG11,NBCO11
      INTEGER IGR22(*),NBLG22,NBCO22
      REAL*8    COORD(*),RAISON
      INTEGER IDIMC,NBCOOR,NBCOUC
      INTEGER NBLIG3,NBCOL3,NBRAN3,IARETE(*),NARETE(*)
      INTEGER ITVL(*),NITMAX
      INTEGER ITRNOE(*),NBNMAX,NBE,NBP
      INTEGER NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr
C
C      COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS
C      REAL*8  XYZHUG,XYZMIN,XYZEPS
C
      INTEGER IGR3
      INTEGER INDICE,I,J,K
      REAL*8    XO,V12,XN,COEF,XYZEPS
      INTEGER NRANAJ,INDXYZ,NUM1,NUM2,KK
      INTEGER NOETRI(1),NBISOL,NOEMAX,NBENUL
      INTEGER IDE,NBCMAX,ITRTRI(1),INUL
      XYZEPS=1.D-10
C
C        =======================================
C     --- 2.CREATION D'UNE GRILLE 3D ET COLLAGE ---
C        =======================================
C
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,
     >  '2. CREATION DE LA GRILLES 3D ET COLLAGE : ',' ')
C
       IGR3 = 1
C      INUL = 0
C      CALL G3CRSP( NBLIG3,NBCOL3,NBRAN3,INUL,INUL,ITVL(IGR3) )
       DO 141 I=1,NBLIG3*NBCOL3*NBRAN3
       ITVL(I) = 0
  141  CONTINUE
C
C        ---------------------------------------------
C     --- 2.1 TRANSFERT DES 2 FACES DANS LA GRILLE 3D ---
C        ---------------------------------------------
C     --- ON TRANSFERT ---
C      IGR1 = (I,J) -> (1,I,J)
C
C
      DO 150 I=1,NBCO11
       DO 140 J=1,NBLG11
         ITVL((J-1)*NBLIG3*NBCOL3 + (I-1)*NBCOL3+IGR3) =
     >   IGR11((J-1)*NBCO11+I)
  140  CONTINUE
  150 CONTINUE
C
C      IGR2 = (I,J) -> (NBCOL,I,J)
C
      DO 170 I=1,NBCO22
       DO 160 J=1,NBLG22
         ITVL((J-1)*NBLIG3*NBCOL3 + (I-1)*NBCOL3+NBCOL3+IGR3-1) =
     >   IGR22((J-1)*NBCO22+I)
  160  CONTINUE
  170 CONTINUE
C
      INDICE = NBCOOR + 1
      DO 190 I=1,(NBRAN3*NBCOL3*NBLIG3)
        IF( ITVL(IGR3+I-1).EQ.0 )THEN
          ITVL(IGR3+I-1) = INDICE
          INDICE = INDICE + 1
        ENDIF
  190 CONTINUE
C
C        ------------------------------------
C     --- 2.2 COLLAGE DES ARETES DU MAILLAGE ---
C        ------------------------------------
C
C     ---  ON PASSE SUR LA STRUCTURE MAILLAGE  ---
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> CONNECTIQUE GRILLE 3D ET COLLAGE',' ')
        CALL ESEINT(1,'COLONNES ',NBCOL3,1)
        CALL ESEINT(1,'LIGNES   ',NBLIG3,1)
        CALL ESEINT(1,'RANGEES  ',NBRAN3,1)
        CALL ESEINT(1,'A COLLER SUR LES ARETES 7,8,10 ET 2  ',
     >              NARETE(1),4)
      ENDIF
C
      CALL H8CRSP(NBCOL3-1,NBLIG3-1,NBRAN3-1,
     >             ITRNOE,NBNMAX,NBE,NBP,iarr)
C
C     --- 1.2 COLLAGE DES ARETES (SUR LE MAILLAGE !) ---
C
      DO 10 I=1,4
        CALL G3GLKK(IARETE(I),NARETE(I),
     >             (NBLIG3-1),(NBCOL3-1),(NBRAN3-1),
     >                        ITRNOE,NBNMAX,iarr)
   10 CONTINUE
      IF( iarr.NE.0)THEN
         CALL DSERRE(1,iarr,'H8RCG2','APPEL G3GLKK')
         GOTO 9999
      ENDIF
C
C     --- RENUMEROTATION DES NOEUDS DU MAILLAGE ---
C            PAR LES NOEUDS DE LA GRILLE
C
      DO 5 I=1,NBE*NBNMAX
        IF(ITRNOE(I).GT.0)ITRNOE(I) = ITVL(IGR3+ITRNOE(I)-1)
    5 CONTINUE
C
C        ----------------------------
C     --- INTERPOLATION LINEAIRE POUR
C         COMPLETER LA GRILLE 3D      ---
C        ----------------------------
C
      INDXYZ = NBCOOR + 1
      IF(ITRACE.GT.0)
     >   CALL ESECHA(1,'-> COORDONNEES GRILLE 3D ',' ')
C
C       NRANAJ = NARETE(1)+NARETE(3)
       NRANAJ = NBCOL3 - 2
       XN = 1 - RAISON**(NRANAJ+1)
       IF((XN.LE.XYZEPS).AND.(XN.GE.-XYZEPS))THEN
         RAISON = 1.0
         XN = 1.0 / (NRANAJ + 1.0)
       ELSE
         XN = 1.0 / XN
       ENDIF
C
       DO 100 I=1,NBLG11
         DO 90 J=1,NBCO11
           DO 80 K=1,NRANAJ
C           --- INTERPOLATION ENTRE LE PLAN IGR11 ET IGR22 ---
            NUM1 = IGR11((I-1)*NBCO11+J)
            NUM2 = IGR22((I-1)*NBCO11+J)
            IF( RAISON.EQ.1 )THEN
              COEF = K
            ELSE
              COEF = 1 - RAISON**K
            ENDIF
            DO 70 KK=1,IDIMC
              XO  =  COORD((NUM1-1)*IDIMC+KK)
              V12 =  COORD((NUM2-1)*IDIMC+KK) - XO
              COORD((INDXYZ-1)*IDIMC+KK) = V12*XN*COEF + XO
   70       CONTINUE
            INDXYZ = INDXYZ + 1
   80       CONTINUE
   90     CONTINUE
  100   CONTINUE
        NBCOOR = INDXYZ - 1
C
C        ============================
C     --- 3. COMPRESSION DES NOEUDS  ---
C        ============================
C
      IF( ICOMPR.EQ. 0 )GO TO 9999
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'* POST TRAITEMENT : ',' COMPRESSION ')
C
      IDE = 3
      NBCMAX = 0
      ITRTRI(1) = 0
      NOEMAX = 0
      NOETRI(1) = 0
      NBENUL = NBE
      NBISOL = NBP
      CALL NUGCNU(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >            NOETRI,NOEMAX,NBE,COORD,IDIMC,NBP,
     >            ITVL,NITMAX,iarr)
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'* MAILLAGE -> COMPRESSION ',' ')
        CALL ESEINT(1,'NOMBRE D ELEMENTS SUPPRIMES : ',NBENUL-NBE,1)
        CALL ESEINT(1,'NOMBRE DE  POINTS SUPPRIMES : ',NBISOL-NBP,1)
      ENDIF
C
 9999 END