Télécharger h8rcg2.eso

Retour à la liste

h8rcg2
C H8RCG2    SOURCE    CHAT      06/03/29    21:23:00     5360
C
C
C
      SUBROUTINE H8RCG2(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 H8RCG2 : MAILLAGE H8 RACCORDANT 2 GRILLES COMPATIBLES
C     OBJET          EN 1 COUCHE 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             ET AVEC NBCOL2 >= NBCOL1 ET NBLIG2 <= NBLIG1
C
C     APPELS      : H8RCGI
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                 NBLIG1*NBCOL2*NBRAN SI ICOMPR= 0
C                 SINON IL FAUT AJOUTER : 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
      INTEGER IDIMC,NBCOOR,NBCOUC,ITVL(*),NITMAX
      INTEGER ITRNOE(*),NBNMAX,NBE,NBP
      INTEGER NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr
C
      INTEGER NBCO11,NBCO22,NBCOL3,NBLG11,NBLG22,NBLIG3,NBRAN3
      INTEGER IGR11,IGR22
      INTEGER IARETE(4),NARETE(4)
      INTEGER INDICE,INCREM
      INTEGER NBCOAJ(2),INCOAJ(2),NBLGAJ(2),INLGAJ(2),NBAJ(2)
      INTEGER ITRAV
C
C        ===============================================
C     --- 0. VERIFICATIONS DES CONDITIONS D'APPLICATION ---
C        ===============================================
      NBE = 0
      IF((NBCOL1.GT.NBCOL2).OR.(NBLIG2.GT.NBLIG1))THEN
         iarr = -1
         CALL DSERRE(1,iarr,'H8RCG2',' INVERSER LES 2 GRILLES ')
         GOTO 9999
      ENDIF
C
      IF( ( MOD(NBCOL1+NBCOL2,2).NE.0 ).OR.
     >    ( MOD(NBLIG1+NBLIG2,2).NE.0 ))THEN
         iarr = -1
         CALL DSERRE(1,iarr,'H8RCG2',
     >               ' PARITE : UNE COUCHE INSUFFISANTE ')
         GOTO 9999
      ENDIF
C
      IF(((NBCOL1.LT.NBCOL2).AND.(NBLIG1.LT.NBLIG2)).OR.
     >   ((NBCOL1.GT.NBCOL2).AND.(NBLIG1.GT.NBLIG2)))THEN
         iarr = -1
         CALL DSERRE(1,iarr,'H8RCG2',' DEUX COUCHES NECESSAIRES ')
         GOTO 9999
      ENDIF
C
      IARETE(1) =  7
      IARETE(2) =  8
      IARETE(3) =  10
      IARETE(4) =  2
      NARETE(1) = ( NBCOL2 - NBCOL1 ) / 2
      NARETE(2) = ( NBCOL2 - NBCOL1 ) / 2
      NARETE(3) = ( NBLIG1 - NBLIG2 ) / 2
      NARETE(4) = ( NBLIG1 - NBLIG2 ) / 2
C
      NBLIG3 = NBCOL2
      NBCOL3 = NARETE(1)+NARETE(3)+2 +NBCOUC-1
      NBRAN3 = NBLIG1
C
      NBE    = (NBLIG3-1)*(NBCOL3-1)*(NBRAN3-1)
      NBP    = NBLIG3*NBCOL3*NBRAN3
      IF((NBEMAX.LT.NBE).OR.(NBPMAX.LT.NBP))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'H8RCG2',' POUR LE MAILLAGE 3D ')
        CALL ESEINT(1,'PLACE NECESSAIRE POUR LES ELEMENTS',NBEMAX,1)
        CALL ESEINT(1,'PLACE NECESSAIRE POUR LES NOEUDS',NBPMAX,1)
        GOTO 9999
      ENDIF
C        ============================
C     --- 1. CREATION DES GRILLES 2D ---
C        ============================
C        -------------------------------------
C     --- ON COMPLETE LES GRILLES A RACCORDER ---
C        -------------------------------------
C         (NBLIG1',NBCOL1') = (NBLIG2',NBCOL2')
C
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'1. ON COMPLETE DES GRILLES SURFACIQUES : ',' ')
C
      INDICE = NBCOOR+1
      INCREM = 1
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> NOUVEAUX NOEUDS',' ')
        CALL ESEINT(1,'A PARTIR DU NUMERO ',INDICE,1)
      ENDIF
C
C     --- ON AJOUTE DES COLONNES A GR1 ---
C
      NBAJ(1)   = 2
      NBAJ(2)   = 0
      INCOAJ(1) = 1
      NBCOAJ(1) = (NBCOL2-NBCOL1) / 2
      NBCOAJ(2) = (NBCOL2-NBCOL1) / 2
      INCOAJ(2) = -NBCOL1
C
      IGR11 = 1
      ITRAV = 1
      IF( NITMAX.LT. (IGR11-1+ NBCOL2*NBLIG1))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'H8RCG2',' POUR COMPLETER LA GRILLE ')
        CALL ESEINT(1,'PLACE NECESSAIRE ',NBCOL2*NBLIG1,1)
        GOTO 9999
      ENDIF
C
      CALL G2POLC(IGR1,NBLIG1,NBCOL1,
     >            NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ,
     >            INDICE,INCREM,COORD,NBCOOR,IDIMC,
     >            ITVL(ITRAV),0,
     >            ITVL(IGR11),NBLG11,NBCO11,iarr)
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'H8RCG2',' APPEL G2POLC ')
        GOTO 9999
      ENDIF
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> GRILLE 1 COMPLETEE',' ')
        CALL ESEINT(1,'COLONNES ',NBCO11,1)
        CALL ESEINT(1,'LIGNES   ',NBLG11,1)
      ENDIF
C
C     --- ON AJOUTE DES LIGNES A GR2 ---
C
      NBAJ(1)   = 0
      NBAJ(2)   = 2
      INLGAJ(1) = 1
      NBLGAJ(1) = (NBLIG1-NBLIG2) / 2
      NBLGAJ(2) = (NBLIG1-NBLIG2) / 2
      INLGAJ(2) = -NBLIG2
C
      IGR22 = IGR11 + NBLIG1*NBCOL2
      IF( NITMAX.LT. (IGR22-1+ NBLIG1*NBCOL2))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'H8RCG2',' POUR COMPLETER LA GRILLE ')
        CALL ESEINT(1,'PLACE NECESSAIRE ',
     >                 IGR22-1+NBLIG1*NBCOL2,1)
        GOTO 9999
      ENDIF
C
      CALL G2POLC(IGR2,NBLIG2,NBCOL2,
     >            NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ,
     >            INDICE,INCREM,COORD,NBCOOR,IDIMC,
     >            ITVL(ITRAV),0,
     >            ITVL(IGR22),NBLG22,NBCO22,iarr)
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'H8RCG2',' APPEL G2POLC ')
        GOTO 9999
      ENDIF
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> GRILLE 2 COMPLETEE',' ')
        CALL ESEINT(1,'COLONNES ',NBCO22,1)
        CALL ESEINT(1,'LIGNES   ',NBLG22,1)
      ENDIF
C        ============================
C     --- 2. CREATION DU RACCORD 3D  ---
C        ============================
C
      NBCOOR = INDICE - 1
      ITRAV  = IGR22 + NBLIG1*NBCOL2
      IF( NBLIG3*NBCOL3*NBRAN3 .GT. (NITMAX-ITRAV+1))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'H8RCG2',' POUR LE RACCORD ')
        CALL ESEINT(1,'PLACE NECESSAIRE ',
     >              NBLIG3*NBCOL3*NBRAN3+ITRAV,1)
        GOTO 9999
      ENDIF
      CALL H8RCGI(ITVL(IGR11),NBLG11,NBCO11,
     >            ITVL(IGR22),NBLG22,NBCO22,
     >            COORD,NBCOOR,IDIMC,NBCOUC,RAISON,
     >            NBLIG3,NBCOL3,NBRAN3,IARETE,NARETE,
     >            ITVL(ITRAV),(NITMAX-ITRAV+1),
     >            ITRNOE,NBNMAX,NBE,NBP,
     >            NBEMAX,NBPMAX,ICOMPR,ITRACE,iarr)
C
C
 9999 END
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales