Sources Esope | Cast3M

q4org2
C Q4ORG2    SOURCE    CB215821  26/10/26    21:16:02     12682          
C
C
      SUBROUTINE Q4ORG2(ITRNO1,NBNMX1,ITRTR1,NBCMX1,NBE1,
     >            ITRNO2,NBNMX2,ITRTR2,NBCMX2,NBE2,N1,N2,
     >            COORD,NBCOOR,IDIMC,
     >            ITVL,NITMAX,
     >            IGR1,NGRMX1,IGR2,NGRMX2,ICOIN,NBNL,ITRACE,iarr)
C     **********************************************************************
C     OBJET Q4ORG2 : TRANSFORME 2 MAILLAGES Q4 EN 2 GRILLES COMPATIBLES
C
C     EN ENTREE   :
C
C       ITRNOE1 : INDICE DES NOEUDS DES ELEMENTS DU PREMIER MAILLAGE
C       NBNMX1  : NOMBRE MAX. DE NOEUDS PAR ELEMENTS (4 OU +)
C       NBE1    : NOMBRE D'ELEMENTS DU PREMIER MAILLAGE
C
C       ITRNOE2,NBNMX2,NBE2 : DEUXIEME MAILLAGE
C
C       N1,N2   : N1 EST LE NUMERO DU NOEUD DU PREMIER MAILLAGE QUI DOIT
C                 ETRE CONNECTE AU NOEUD N2 DANS LE DEUXIEME MAILLAGE
C
C       COORD   : COORDONNEES DES NOEUDS
C       IDIMC   : DIMENSION DE L'ESPACE
C       NBCOOR  : NOMBRE DE NOEUDS
C
C       ITVL    : TABLEAU D'ENTIERS POUR LES CALCULS
C       NTIMAX  : TAILLE DU TABLEAU ITVL
C               ON A BESOIN DU TABLEAU DE TRAVAIL SEULEMENT SI ON CHANGE
C               SIMULTANEMENT L'ORIGINE ET L'ORIENTATION DU MAILLAGE.
C               LA PLACE NECESSAIRE EST ALORS DE : NBCOL*NBLIG = NBN
C               QUI EST TOUJOURS INFERIEUR A : 3+2*MAX(NBE1,NBE2)
C
C     EN SORTIE   :
C
C       IGR1     : GRILLE ORIGINE
C       IGR2     : GRILLE DESTINATION
C       ICOIN    : LES INDICES DES COINS DES 2 GRILLES
C       NBNL     : NOMBRE DE COLONNES ET DE LIGNES DES 2 GRILLES
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,
C                 AVEC NBCOL2 >= NBCOL1 ET NBLIG2 &lt;= NBLIG1
C
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER ITRNO1(*),NBNMX1,ITRTR1(*),NBCMX1,NBE1
      INTEGER ITRNO2(*),NBNMX2,ITRTR2(*),NBCMX2,NBE2,N1,N2
      REAL*8    COORD(*)
      INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
      INTEGER IGR1(*),NGRMX1,IGR2(*),NGRMX2
      INTEGER ICOIN(*),NBNL(*),ITRACE,iarr
C
      REAL*8     VK(3),XNVK,ZERO
      INTEGER  NBLIG1,NBCOL1,NBLIG2,NBCOL2,NBCOL,NBLIG
      INTEGER  I,IOP,ITAMPO
      EXTERNAL XNORVE
      REAL*8     XNORVE
C
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'* PRETRAITEMENT : ',
     >                ' CALCUL DES GRILLES SURFACIQUES ')
C
      DO 10 I=1,8
        ICOIN(I) = 0
   10 CONTINUE
      DO 20 I=1,4
        NBNL(I) = 0
   20 CONTINUE
C
C        =========================
C     --- CALCUL DE L'ORIENTATION ---
C        =========================
C
      ZERO = 1.E-6
C      CALL DIFFVE(COORD((N2-1)*IDIMC+1),
C     >            COORD((N1-1)*IDIMC+1),
C     >            IDIMC,VK)
      DO 730 JG=1,IDIMC
      VK(JG)=COORD((N2-1)*IDIMC+JG) - COORD((N1-1)*IDIMC+JG)
 730  CONTINUE
      XNVK = XNORVE(VK,IDIMC)
      IF( XNVK.LT.ZERO )THEN
         iarr = -1
         CALL DSERRE(1,iarr,'Q4ORG2',
     >               ' LES NOEUDS (N1,N2) SONT CONFONDUS ')
        GOTO 9999
      ENDIF
C      CALL MUSCVE( VK,XNVK,IDIMC, VK )
       DO 710 JG=1,IDIMC
       VK(JG)=VK(JG)*XNVK
  710  CONTINUE
C
C        ===========================
C     --- CALCUL DE LA 1IERE GRILLE ---
C        ===========================
C
      CALL G2ORQ4(ITRNO1,NBNMX1,ITRTR1,NBCMX1,NBE1,
     >            COORD,IDIMC,N1,VK,
     >            ITVL,NITMAX,
     >            IGR1,NBCOL1,NBLIG1,NGRMX1,
     >            ICOIN,iarr )
C
      NBNL(1) = NBCOL1
      NBNL(2) = NBLIG1
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> DU MAILLAGE 1 A LA GRILLE 1',' ')
        CALL ESEINT(1,'NUMERO DES COINS : ',ICOIN(1),4)
        CALL ESEINT(1,'COLONNES,LIGNES  : ',NBNL(1),2)
      ENDIF
      IF( iarr.NE. 0 )THEN
         CALL DSERRE(1,iarr,'Q4ORG2',' APPEL G2ORQ4')
         CALL DSERRE(1,iarr,'Q4ORG2',
     >               ' PASSAGE PREMIER MAILLAGE EN GRILLE ')
        GOTO 9999
      ENDIF
C
C        ===========================
C     --- CALCUL DE LA 2IERE GRILLE ---
C        ===========================
C
      CALL G2ORQ4(ITRNO2,NBNMX2,ITRTR2,NBCMX2,NBE2,
     >            COORD,IDIMC,N2,VK,
     >            ITVL ,NITMAX,
     >            IGR2,NBCOL2,NBLIG2,NGRMX2,
     >            ICOIN(5),iarr )
C
      NBNL(3) = NBCOL2
      NBNL(4) = NBLIG2
C
      IF(ITRACE.GT.0)THEN
        CALL ESECHA(1,'-> DU MAILLAGE 2 A LA GRILLE 2',' ')
        CALL ESEINT(1,'NUMERO DES COINS : ',ICOIN(5),4)
        CALL ESEINT(1,'COLONNES,LIGNES  : ',NBNL(3),2)
      ENDIF
      IF( iarr.NE. 0 )THEN
         CALL DSERRE(1,iarr,'Q4ORG2',' APPEL G2ORQ4')
         CALL DSERRE(1,iarr,'Q4ORG2',
     >               ' PASSAGE DU DEUXIEME MAILLAGE EN GRILLE ')
        GOTO 9999
      ENDIF
C
C         ====================================================
C     ---- INVERSION DES LIGNES ET DES COLONNES DES 2 GRILLES ----
C         ====================================================
C
      IF((NBCOL1.GT.NBCOL2 ).AND.(NBLIG1.GT.NBLIG2))THEN
        iarr = -1
        NBNL(1) = NBCOL1
        NBNL(2) = NBLIG1
        NBNL(3) = NBCOL2
        NBNL(4) = NBLIG2
        GOTO 9999
      ENDIF
C
      IF((NBCOL1.GT.NBCOL2 ).OR.(NBLIG2.GT.NBLIG1))THEN
C
      IF(ITRACE.GT.0)
     >  CALL ESECHA(1,' REORIENTATION : ',
     >                ' ROTATION DES GRILLES SURFACIQUES ')
C
        IF( ( (NITMAX - NBCOL1*NBLIG1).LT.0 ).OR.
     >      ( (NITMAX - NBCOL2*NBLIG2).LT.0 ) )THEN
          iarr = -2
          CALL DSERRE(1,iarr,'Q4ORG2',
     >               ' POUR LA REORIENTATION DES GRILLES ')
          GOTO 9999
        ENDIF
C
        IOP = 2
        CALL G2COPY(IGR1,NBCOL1,NBLIG1,IOP,
     >              ITVL,NBCOL,NBLIG )
        IOP = 1
        CALL G2COPY(ITVL,NBCOL,NBLIG,IOP,
     >              IGR1,NBCOL1,NBLIG1 )
        ITAMPO = ICOIN(1)
        ICOIN(1) = ICOIN(4)
        ICOIN(4) = ICOIN(3)
        ICOIN(3) = ICOIN(2)
        ICOIN(2) = ITAMPO
        NBNL(1) = NBCOL1
        NBNL(2) = NBLIG1
C
        IOP = 2
        CALL G2COPY(IGR2,NBCOL2,NBLIG2,IOP,
     >              ITVL,NBCOL,NBLIG )
        IOP = 1
        CALL G2COPY(ITVL,NBCOL,NBLIG,IOP,
     >              IGR2,NBCOL2,NBLIG2 )
        ITAMPO = ICOIN(5)
        ICOIN(5) = ICOIN(8)
        ICOIN(8) = ICOIN(7)
        ICOIN(7) = ICOIN(6)
        ICOIN(6) = ITAMPO
        NBNL(3) = NBCOL2
        NBNL(4) = NBLIG2
C
        IF(ITRACE.GT.0)THEN
          CALL ESECHA(1,'-> GRILLE 1 REOREINTEE ',' ')
          CALL ESEINT(1,'COLONNES,LIGNES  : ',NBNL(1),2)
          CALL ESECHA(1,'-> GRILLE 2 REORIENTEE ',' ')
          CALL ESEINT(1,'COLONNES,LIGNES  : ',NBNL(3),2)
        ENDIF
      ENDIF
C
 9999 END