Sources Esope | Cast3M

h8rcgg
C H8RCGG    SOURCE    CHAT      06/03/29    21:23:05     5360
C     **********************************************************************
C     FICHIER  : GR3D_RACC.F
C     OBJET    : RACCORD DE 2 MAILLAGES GRILLES.
C     FONCT.   :
C
C     OBJET H8RCGG : MAILLAGE H8 RACCORDANT 2 GRILLES COMPATIBLES
C     OBJET          EN 2 COUCHES MINI.(NBCOL2 >= NBCOL1,NBLIG2 >= NBLIG1)
C     OBJET H8RCG2 : MAILLAGE H8 RACCORDANT 2 GRILLES COMPATIBLES
C     OBJET          EN 1 COUCHE MINI.(NBCOL2 >= NBCOL1,NBLIG2 &lt;= NBLIG1)
C     OBJET H8RCGI : MAILLAGE H8 S'APPUYANT 2 GRILLES IDENTIQUES
C
C     AUTEUR   : O. STAB
C     DATE     : 06.96
C     MODIFICATIONS :
C        AUTEUR, DATE, OBJET :
C
C
C     **********************************************************************
C
      SUBROUTINE H8RCGG(IGR1,NBLIG1,NBCOL1,
     >            IGR2,NBLIG2,NBCOL2,COORD,NBCOOR,IDIMC,NBCOUC,RAISON,
     >            ITVL,NITMAX,
     >            ITRNOE,NBNMAX,NBE,NBP,
     >            NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr)
C     **********************************************************************
C     OBJET H8RCGG : MAILLAGE H8 RACCORDANT 2 GRILLES COMPATIBLES
C     OBJET          EN 2 COUCHES MINI.(NBCOL2 >= NBCOL1,NBLIG2 >= NBLIG1)
C
C             LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON
C             AVEC UNE ORIGINE COMPATIBLE IGR1(1) CORRESPOND A IGR2(1)
C
C     APPELS      : H8RCG2
C
C     EN ENTREE   :
C
C       IGR1,NBLIG1,NBCOL1 : LA PREMIERE GRILLE
C                            IGR CONTIENT LES NUMEROS DES NOEUDS
C       IGR2,NBLIG2,NBCOL2 : LA DEUXIEME GRILLE
C       NBCOUC             : NOMBRE DE COUCHES SUPPLEMENTAIRES
C                            (PAR DEFAUT 1 SEULE COUCHE)
C
C       COORD,IDIMC        : POSITION DES NOEUDS
C
C       ITVL    : TABLEAU D'ENTIERS POUR LES CALCULS
C       NITMAX  : TAILLE DE ITVL, LA PLACE NECESSAIRE EST DE
C                  2*NBCOL1*NBLIG2 POUR LA GRILLE INTERMEDIAIRE
C                + NBLIG1*NBCOL2*NBRAN
C                 SI ICOMPR != 0 IL FAUT AJOUTER :
C                  NBLIG3*NBCOL3*(NBRAN3-2) + NBCOOR
C                 AVEC NBRAN = (3+NBCOUC+NBCOL2+NBLIG2-NBCOL1-NBLIG1)
C
C       ITRNOE : TABLEAU DES ELEMENTS (A REMPLIR)
C       NBEMAX : NOMBRE MAXIMUM D'ELEMENTS
C       NBNMAX : 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,NBCMAX,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 IGR1(*),NBLIG1,NBCOL1
      INTEGER IGR2(*),NBLIG2,NBCOL2
      REAL*8    COORD(*),RAISON,XYZEPS
      INTEGER IDIMC,NBCOOR,NBCOUC,ITVL(*),NITMAX
      INTEGER ITRNOE(*),NBNMAX,NBE,NBP
      INTEGER NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr
C
C      COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS
CS      REAL*8  XYZHUG,XYZMIN,XYZEPS
C
      INTEGER NBLIG3,NBCOL3,NBRAN3,NBEGEN,NBPGEN
      INTEGER IGR3,ITRAV,ITRVMX,INDICE,ITRNO3,NBE3
      INTEGER NBCOU1,NBCOU2
      REAL*8    RAPP,CNDELG,CNDECO,RAISO3,RBCOU1,RBCOU2,UNR
C
C        -----------------------------------
C     --- EVALUATION DE LA PLACE NECESSAIRE ---
C        -----------------------------------
      XYZEPS=1.d-10
      NBLIG3 = NBCOL1
      NBCOL3 = (NBLIG2-NBLIG1)/2 +2+NBCOUC-1
      NBRAN3 = NBLIG2
C
      NBEGEN = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1)
      NBPGEN = NBLIG3*NBCOL3*NBRAN3
C
      NBLIG3 = NBCOL2
      NBCOL3 = (NBCOL2-NBCOL1)/2 +2+NBCOUC-1
      NBRAN3 = NBLIG2
C
      NBEGEN = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1) + NBEGEN
      NBPGEN = NBLIG3*NBCOL3*NBRAN3             + NBPGEN
C
C     --- MAILLAGE EN H8 ---
C
      IF((NBEMAX.LT.NBEGEN).OR.(NBPMAX.LT.NBPGEN))THEN
        iarr = -2
        GOTO 9999
      ENDIF
C
         IGR3   = 1
C         ITRAV  = NBCOL2*NBLIG1 + IGR3
C
C        BUG18 : PLACE INSUFISANTE - CORRECT 17.03.97 O.STAB
C
         ITRAV  = MAX(NBCOL2*NBLIG1,NBCOL1*NBLIG2) + IGR3
         ITRVMX = NITMAX - ITRAV
         INDICE = NBCOOR + 1
C        --- IGR1 -> IGR3 AUGMENTANT LES LIGNES ---
C
C         ===============================
C     ---- REPARTITION SUR LES 2 COUCHES ----
C         ===============================
C
C      CNBCO = (NBCOL2 - NBCOL1 )/2 + 1
C      CNBLG = (NBLIG2 - NBLIG1 )/2 + 1
C      RAPP  =  CNBLG / (CNBLG+CNBCO)
C
      CNDELG = (NBLIG2 - NBLIG1)/2.0 + 1.0
      CNDECO = (NBCOL2 - NBCOL1)/2.0 + 1.0
      UNR = 1.0
      RBCOU1 = MAX((NBCOUC*CNDELG)/(CNDELG+CNDECO), UNR)
      RBCOU2 = MAX((NBCOUC*CNDECO)/(CNDELG+CNDECO), UNR)
      NBCOU1 = NINT(RBCOU1)
      NBCOU2 = NINT(RBCOU2)
C
      RAPP = 1. - RAISON**(NBCOU1+NBCOU2)
      IF((RAPP.LE.XYZEPS).AND.(RAPP.GE.-XYZEPS))THEN
C        RAPP = N1 / (N1 + N2)
        RAPP = CNDELG / (CNDELG+CNDECO)
C        RAISO3 = RAISON
      ELSE
        RAPP =(1.-RAISON**NBCOU1)/(1.-RAISON**(NBCOU1+NBCOU2))
C        RAISO3 = RAISON**NBCOU1
      ENDIF
      RAISO3 = RAISON
C
         CALL G2LLG2(IGR1,NBLIG1,NBCOL1,
     >               IGR2,NBLIG2,NBCOL2,
     >               COORD,NBCOOR,IDIMC,INDICE,RAPP,
     >               ITVL(ITRAV),ITRVMX,
     >               ITVL(IGR3),NBLIG3,NBCOL3,ITRACE,iarr)
C
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'ESG3CR',' APPEL G2LLG2')
        GOTO 9999
      ENDIF
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'->  GRILLE INTERMEDIAIRE ',' ')
        CALL ESEINT(1,'COLONNES  : ',NBCOL3,1)
        CALL ESEINT(1,'LIGNES    : ',NBLIG3,1)
        CALL ESEINT(1,'NOEUDS GENERES : ',INDICE - 1 - NBCOOR,1)
      ENDIF
      NBCOOR = INDICE - 1
C
      IF(ITRACE.GT.0)CALL ESECHA(1,' PREMIERE COUCHE : ',' ')
      ITRVMX  = NITMAX - ITRAV
      RAISO3 = 1.0 / RAISON
      CALL H8RCG2(ITVL(IGR3),NBLIG3,NBCOL3,
     >            IGR1,NBLIG1,NBCOL1,
     >            COORD,NBCOOR,IDIMC,NBCOU1,RAISO3,
     >            ITVL(ITRAV),ITRVMX,
     >            ITRNOE,NBNMAX,NBE,NBP,
     >            NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr)
C
      IF(ITRACE.GT.0)CALL ESECHA(1,' DEUXIEME COUCHE : ',' ')
      ITRNO3  = NBNMAX*NBE + 1
      RAISO3 = RAISON
      CALL H8RCG2(ITVL(IGR3),NBLIG3,NBCOL3,
     >            IGR2,NBLIG2,NBCOL2,
     >            COORD,NBCOOR,IDIMC,NBCOU2,RAISO3,
     >            ITVL(ITRAV),ITRVMX,
     >            ITRNOE(ITRNO3),NBNMAX,NBE3,NBP,
     >            NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr)
      NBE = NBE + NBE3
C
 9999 END