Sources Esope | Cast3M

g2llg2
C G2LLG2    SOURCE    CHAT      06/03/29    21:21:50     5360
C
C
      SUBROUTINE G2LLG2(IGR1,NBLIG1,NBCOL1,
     >            IGR2,NBLIG2,NBCOL2,
     >            COORD,NBCOOR,IDIMC,INDICE,RAPP,
     >            ITVL,NITMAX,
     >            IGRI,NBLIGI,NBCOLI,ITRACE,iarr)
C     **********************************************************************
C     OBJET G2LLG2 : CREER UNE GRILLE INTERMEDIAIRE (ENTRE 2 GRILLES)
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       COORD,NBCOORD,IDIMC : POSITION DES NOEUDS
C
C       RAPP    : RAPPORT DES DISTANCES ENTRE LES GRILLES
C                 (IGRI-IGR1) / (IGR2-IGR1)
C
C       ITVL    : TABLEAU D'ENTIERS POUR LES CALCULS
C       NITMAX  : TAILLE DE ITVL
C               ON A BESOIN DU TABLEAU DE TRAVAIL POUR COMPLETER IGR1
C               LA PLACE NECESSAIRE EST DE : NBCOL1*NBLIG2
C
C     EN SORTIE   :
C
C       IGRI(NBLIGI,NBCOLI) : GRILLE SURFACIQUE INTERMEDIAIRE
C            NBLIGI = NBLIG2, NBCOLI = NBCOL1
C
C       INDICE  : DU DERNIER NOEUD CREE
C
C       iarr    : CODE D'ERREUR -1 SI DONNEES INCORRECTES
C                               -2 SI TABLEAUX INSUFFISANTS
C
C     REMARQUES : LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON
C                 AVEC UNE ORIGINE COMPATIBLE (VOIR G2ORIG, G2ORIE)
C                 AVEC NBCOL2 >= NBCOL1 ET NBLIG2 &lt;= NBLIG1
C
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER IGR1(*),NBLIG1,NBCOL1
      INTEGER IGR2(*),NBLIG2,NBCOL2
      REAL*8    COORD(*),RAPP
      INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
      INTEGER INDICE
      INTEGER IGRI(*),NBLIGI,NBCOLI,ITRACE,iarr
C
      INTEGER NBCO11,NBLG11,IGR11
      INTEGER NBCOAJ(2),INCOAJ(2),NBLGAJ(2),INLGAJ(2),NBAJ(2)
      INTEGER INDXYZ,INCREM,ITRAV,I,J,K,NUM1,NUM2,IDECAL
C      REAL*8    COEF,CNBLG,CNBCO,
      REAL*8    XO,V12
C
C        ===============================================
C     --- 0. VERIFICATIONS DES CONDITIONS D'APPLICATION ---
C        ===============================================
      IF(NBCOL1.GT.NBCOL2)THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2LLG2',' 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,'G2LLG2',' UNE COUCHE INSUFFISANTE ')
         GOTO 9999
      ENDIF
C
      IF((NBCOL1.LE.NBCOL2).AND.(NBLIG1.GE.NBLIG2))THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2LLG2',' UNE COUCHE SUFFISANTE ')
         GOTO 9999
      ENDIF
C
      IF(ITRACE.GT.0)
     >   CALL ESECHA(1,'-> RACCORD EN 2 COUCHES',' ')
C
C        ===============================================
C     --- 1. CALCUL DE LA SURFACE INTERMEDIAIRE : GRI ---
C         GRI -> GR2 : ON AUGMENTE SEULEMENT LES COLONNES
C         GR1 -> GRI : ON AUGMENTE SEULEMENT LES LIGNES
C        ===============================================
      NBLIGI = NBLIG2
      NBCOLI = NBCOL1
C         ------------------------------------
C     ---- 1.1 ON COMPLETE  LES LIGNES DE GR1 ---
C         ------------------------------------
      NBAJ(1)   = 0
      NBAJ(2)   = 2
      INLGAJ(1) = 1
      NBLGAJ(1) = (NBLIG2-NBLIG1) / 2
      NBLGAJ(2) = (NBLIG2-NBLIG1) / 2
      INLGAJ(2) = -NBLIG1
C
      IGR11 = 1
      ITRAV = 1
      IF( NITMAX.LT. (IGR11-1+ NBCOL1*NBLIG2))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'G2LLG2',' POUR COMPLETER LA GRILLE ')
        CALL ESEINT(1,'PLACE NECESSAIRE ',NBCOL1*NBLIG2,1)
        GOTO 9999
      ENDIF
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
      CALL G2POLC(IGR1,NBLIG1,NBCOL1,
     >            NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ,
     >            INDICE,INCREM,COORD,NBCOOR,IDIMC,
     >            ITVL(ITRAV),0,
     >            ITVL(IGR11),NBLG11,NBCO11,iarr)
C
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'G2LLG2',' 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        -----------------------------------------
C     --- 1.2 CREATION D'UNE GRILLE 2D ET COLLAGE ---
C        -----------------------------------------
C
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,
     >  '2. CREATION DE LA GRILLES 3D ET COLLAGE : ',' ')
C
C      CALL G2CRSP( NBLIGI,NBCOLI,INDICE,INCREM,IGRI )
      DO 710 JG=1,(NBLIGI*NBCOLI)
        IGRI(JG)=INDICE
        INDICE = INDICE + INCREM
  710 CONTINUE
C        ----------------------------
C     --- 1.3 INTERPOLATION LINEAIRE
C             POUR LA GRILLE 2D      ---
C        ----------------------------
C
      INDXYZ = NBCOOR + 1
      IF(ITRACE.GT.0)
     >   CALL ESECHA(1,'-> COORDONNEES GRILLE 2D ',' ')
C
       IDECAL = ( NBCOL2 - NBCOL1 ) / 2
 
C
C      --- INTERPOLATION REMPLISSAGE PAR LIGNE ---
C
       DO 110 I=1,NBLG11
            NUM1 = ITVL((I-1)*NBCO11+1+IGR11-1)
            NUM2 = IGR2((I-1)*NBCOL2+1)
            DO 70 K=1,IDIMC
              XO  =  COORD((NUM1-1)*IDIMC+K)
              V12 =  COORD((NUM2-1)*IDIMC+K) - XO
              COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
   70       CONTINUE
            INDXYZ = INDXYZ + 1
       DO 90 J=2,NBCOL1-1
C       CORRECTION DU BUG : 1 => J
            NUM1 = ITVL((I-1)*NBCO11+J+IGR11-1)
            NUM2 = IGR2((I-1)*NBCOL2+J+IDECAL)
            DO 80 K=1,IDIMC
              XO  =  COORD((NUM1-1)*IDIMC+K)
              V12 =  COORD((NUM2-1)*IDIMC+K) - XO
              COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
   80       CONTINUE
            INDXYZ = INDXYZ + 1
   90  CONTINUE
            NUM1 = ITVL(I*NBCO11+IGR11-1)
            NUM2 = IGR2(I*NBCOL2)
            DO 100 K=1,IDIMC
              XO  =  COORD((NUM1-1)*IDIMC+K)
              V12 =  COORD((NUM2-1)*IDIMC+K) - XO
              COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
  100       CONTINUE
            INDXYZ = INDXYZ + 1
  110  CONTINUE
C
C
 9999 END