Sources Esope | Cast3M

g2noq4
C G2NOQ4    SOURCE    CHAT      06/03/29    21:22:00     5360
C
C
      SUBROUTINE G2NOQ4( ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,
     >                   INOGR,NBCOL,NBLIG,NNOMAX,iarr)
C     **********************************************************************
C     OBJET G2NOQ4 : CONSTRUIT LA GRILLE DES NOEUDS
C
C     EN ENTREE   :
C         ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE : UN MAILLAGE 2D
C
C         INOGR  : INDICE DES NOEUDS DE LA GRILLE (A REMPLIR)
C         NNOMAX : TAILLE DE INOGR
C
C         ITVL(ITVMAX) : TABLEAU DE TRAVAIL (ENTIERS)
C
C     EN SORTIE   :
C         NBLIG,NBCOL : NOMBRE DE LIGNES ET DE COLONNES DE LA GRILLE
C         INOGR   : INDICE DES NOEUDS DE LA GRILLE
C                   INOGR((I-1)*NBCOL+J) = NOEUD DE LA COLONNE J
C                                          ET DE LA LIGNE I
C         iarr    : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES
C
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBE
      INTEGER INOGR(*),NBCOL,NBLIG,NNOMAX,iarr
C
      INTEGER IEK(4),ICK(4),NKK,NN(4),NKKMAX
      INTEGER I,J,N1,N2,N3,N4,IECOL,ICCOL,IE,IC,IES,ICS
C              ========================
C     --------- 1. RECHERCHE DES COINS --------
C              ========================
C
      NKKMAX = 4
      CALL G2KKM2( ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,
     >                   NN,IEK,ICK,NKK,NKKMAX,iarr)
      IF( iarr.NE.0 )THEN
         CALL DSERRE(1,iarr,'G2NOQ4','APPEL G2KKM2')
         GOTO 9999
      ENDIF
      IF( NKK.NE.4 )THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2NOQ4','IL DOIT Y AVOIR 4 COINS')
         GOTO 9999
      ENDIF
      IF( (NN(1).NE.NN(3)).OR.(NN(2).NE.NN(4)) )THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2NOQ4',
     >   ' LE NB DE SEGMENT DOIT ETRE EGAL SUR LES COTE OPPOSES')
         GOTO 9999
      ENDIF
      IF( (NN(1)*NN(2)).GT.NNOMAX )THEN
         iarr = -2
         CALL DSERRE(1,iarr,' G2NOQ4 ',' TROP DE POINTS')
         GOTO 9999
      ENDIF
C              =============================
C     --------- 2. REMPLISSAGE DE LA GRILLE --------
C              =============================
      NBCOL = NN(1)
      NBLIG = NN(2)
      IE = IEK(1)
      IC = ICK(1)
      DO 200 I=1,(NBLIG-1)
C
C     ---- POUR CHAQUE LIGNE DE LA GRILLE ----
C
      DO 100 J=1,(NBCOL-1)
        IF((IE.LE.0).OR.(IC.LE.0))THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2NOQ4',
     >   ' LE MAILLAGE N A PAS LA STRUCTURE DE GRILLE')
         GOTO 9999
        ENDIF
C
C     ----- PARCOURS DU Q4 ----
C
        N1  = ITRNOE((IE-1)*NBNMAX+IC)
        IC  = MOD(IC,NBCMAX) + 1
        N2  = ITRNOE((IE-1)*NBNMAX+IC)
C     ----- ELEMENT SUIVANT SUR LA MEME LIGNE ----
        CALL SESFR1(IE,IC,ITRTRI,NBCMAX,IES,ICS)
        ICS = MOD(ICS,NBCMAX) + 1
C
        IC  = MOD(IC,NBCMAX) + 1
        N3  = ITRNOE((IE-1)*NBNMAX+IC)
C     ----- PREMIER ELEMENT DE LA LIGNE SUIVANTE ----
      IF( J.EQ.1 )THEN
        CALL SESFR1(IE,IC,ITRTRI,NBCMAX,IECOL,ICCOL)
      ENDIF
        IC  = MOD(IC,NBCMAX) + 1
        N4  = ITRNOE((IE-1)*NBNMAX+IC)
C
C     ----- STOCKAGE DES NOEUDS ----
C
      IF( I.EQ.1 )THEN
        INOGR((I-1)*NBCOL + J)     = N1
        INOGR((I-1)*NBCOL + J + 1) = N2
      ELSE
C       --- ON VERIFIE L ADJACENCE DES LIGNES ---
        IF( (INOGR((I-1)*NBCOL + J)    .NE.N1).OR.
     >      (INOGR((I-1)*NBCOL + J + 1).NE.N2) )THEN
         iarr = -1
         CALL DSERRE(1,iarr,'G2NOQ4',
     >   ' LES LIGNES NE SONT PAS ADJACENTES')
         GOTO 9999
        ENDIF
      ENDIF
      INOGR( I*NBCOL + J + 1) = N3
      INOGR( I*NBCOL + J )    = N4
C     ----- ON PASSE AU Q4 SUIVANT DANS LA LIGNE -----
C
      IE = IES
      IC = ICS
  100 CONTINUE
C     ----- ON PASSE A LA LIGNE SUIVANTE -----
C
      IE = IECOL
      IC = ICCOL
  200 CONTINUE
      GOTO 9999
C
C     8888 CALL DSERRE(1,iarr,' G2KKM2 ',' ')
 9999 END