Sources Esope | Cast3M

dallos
C DALLOS    SOURCE    CHAT      06/03/29    21:18:13     5360
C
C
      SUBROUTINE DALLOS(IREGIO,FER,XPROJ,NBLIG,NBCOL,NKCOIN,
     >                  IPT3,NBE,NBN,IERRDS)
C     **********************************************************************
C     OBJET DALLOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
C     OBJET          LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
C
C     EN ENTREE   :
C         IREGIO  : IREGIO(I) NOMBRE D'ELEMENTS SUR LE COTE I
C         FER     : DESCRIPTION DU CONTOUR (NUMERO DES NOEUDS)
C         XPROJ   : COORDONNEES DES POINTS DU CONTOUR (PROJETE DANS LE PLAN)
C         NBLIG   : NOMBRE DE LIGNE DE LA GRILLE
C         NBCOL   : NOMBRE DE COLONNES DE LA GRILLE
C         NKCOIN  : NKCOIN(I) NOMBRE DE LIGNE ET DE COLONNES
C                   A ENLEVER AU COIN I
C     EN SORTIE   :
C         IPT3    : LE MAILLAGE QUADRANGULAIRE LINAIRE RESULTANT
C         NBE     : NOMBRE D'ELEMENTS DU MAILLAGE
C         NBN     : NOMBRE DE NOEUDS DU MAILLAGE (AVEC NOEUDS MILIEUX)
C         IERRDS  : CODE D'ERREUR -1 DONNEES INCORRECTE, 0 OK
C
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INTEGER IREGIO(4),NBLIG,NBCOL,NKCOIN(4)
      INTEGER NBE,NBN,IERRDS
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
      SEGMENT ITRAVX
       INTEGER ITVL (ITOTAI)
      ENDSEGMENT
      SEGMENT RTRAVX
       REAL*8 RTVL (ITOTAR)
      ENDSEGMENT
      SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR),AFER.FER
* ATTENTION SI XPROJ A 4 COMPOSANTES CE SONT X Y D Z
      SEGMENT  XPROJ(N,1)
C
C      WRITE (6,*) 'ON A LANCER DALL'
C        ====================================
C     --- ALLOCATION DES TABLEAUX DE TRAVAIL ---
C        ====================================
      ITRACE = 0
      IDIMC  = XPROJ(/1)
      NBNMAX = 4
      NBCMAX = NBNMAX
C     write (6,*) 'idimc = ',idimc
      NBEMAX = (NBLIG-1)*(NBCOL-1)
      NBPMAX = NBLIG*NBCOL
      NBPOLY = IREGIO(1)+IREGIO(2)+IREGIO(3)+IREGIO(4)
      NITMAX = 8*NBEMAX +6*NBPMAX+NBPOLY+1
      NRTMAX = IDIMC * NBPMAX
      ITOTAI = NITMAX
      SEGINI ITRAVX
      ITOTAR = NRTMAX
      SEGINI RTRAVX
C
C        =======================
C     --- TRANSFERT DU POLYGONE ---
C        =======================
C     ITVL(IPOLY) = REFERENCE DANS XPROJ
C
C     ATTENTION LES NOEUDS MILIEUX SONT MIS AU DEBUT
C
      IDEBUT = MAI(1) + 1
C      IF( ITOUR .NE.1 )THEN
C        WRITE(6,*) 'ATTENTION PLUS D UN CONTOUR '
C      ENDIF
C      IF( NBPOLY .NE. (MAI(ITOUR +1)-IDEBUT+1))THEN
C        WRITE(6,*) 'NBPOLY = ',NBPOLY
C        WRITE(6,*) 'MAI(1),MAI(ITOUR +1)=',
C     >              MAI(1),MAI(ITOUR +1)
C      ENDIF
C
      IPOLY = 1
      DO 10 I=1,NBPOLY
        ITVL(I-1+IPOLY) = I
   10 CONTINUE
      ITVL(NBPOLY+IPOLY) = 1
C
      ICOORD = 1
      DO 30 I=1,NBPOLY
        DO 20 J=1,IDIMC
          RTVL((I-1)*IDIMC+J-1+ICOORD) = XPROJ(J,I+IDEBUT-1)
   20   CONTINUE
   30 CONTINUE
C
C        =====================================
C     --- ALLOCATION  DES TABLEAUX DE DONNEES ---
C        =====================================
C
      NBE    = 0
      NBN    = 0
      ITRNOE = NBPOLY + IPOLY + 1
      ITRTRI = NBEMAX*NBNMAX + ITRNOE
      NOETRI = NBEMAX*NBCMAX + ITRTRI
      NOEMAX = NBPMAX
      ITRAV  = NBPMAX + NOETRI
      ITRVMX = NITMAX-ITRAV+1
C
      IF( (NRTMAX-ICOORD+1).LT.(NBPMAX*IDIMC))THEN
        IERRDS = -2
        CALL ESERRO(1,IERRDS,'DALLOS',' RTVL TROP PETIT')
        GOTO 8888
      ENDIF
C
      IF(ITRVMX.LT.(3*(NBLIG*NBCOL)))THEN
        IERRDS = -2
C        write(6,*) 'NITMAX =',NITMAX
C        write(6,*) 'ITRNOE =',ITRNOE
C        write(6,*) 'NBEMAX =',NBEMAX
        CALL ESERRO(1,IERRDS,'DALLOS',' ITVL TROP PETIT')
        GOTO 8888
      ENDIF
C
C
      IF(ITRACE.GT.0)THEN
       CALL ESECHA(1,'MAILLAGE D UN DOMAINE A 4 COTES',' ')
      ENDIF
C
C     WRITE(6,*)'POLY =',(ITVL(IPOLY+I-1),I=1,NBPOLY+1)
C      WRITE(6,*)'COORD =',
C     >     ((RTVL((I-1)*IDIMC+J),J=1,IDIMC),I=1,NBPOLY)
C
C      ITRACE = 1
C
C        =====================================
C     --- APPEL A L'ALGORITHME  : BLOCOS     ---
C        =====================================
C
      ICOMPR = 1
      ILISS  = 1
      W      = 0.75
      EPSLIS = 0.0
      DO 50 I=1,NBPOLY
        N1 = ITVL(I-1+IPOLY)
        N2 = ITVL(I+IPOLY)
        DEPS = 0.0
        DO 40 J=1,IDIMC
          DEPS = DEPS + (RTVL((N1-1)*IDIMC+J-1+ICOORD) -
     >                   RTVL((N2-1)*IDIMC+J-1+ICOORD))**2
   40   CONTINUE
        IF(EPSLIS.EQ.0.0)EPSLIS = DEPS
        IF(DEPS.LT.EPSLIS)EPSLIS = DEPS
   50 CONTINUE
      EPSLIS = 0.001 * SQRT(EPSLIS)
C      WRITE(6,*) 'EPSLIS = ',EPSLIS
C
      CALL BLOCOS(ITVL(IPOLY),IREGIO,
     >      RTVL(ICOORD),IDIMC,NBPOLY,
     >      NBLIG,NBCOL,NKCOIN,
     >      ITVL(ITRAV),ITRVMX,
     >      IDE,ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),
     >      NBCMAX,ITVL(NOETRI),NOEMAX,
     >      NBE,NBN,NBEMAX,NBPMAX,
     >      ICOMPR,ILISS,EPSLIS,W,
     >      ITRACE,IERCOD,IERRDS)
C
C      CALL Q4CR4C(ITVL(IPOLY),IREGIO,
C     >      RTVL(ICOORD),IDIMC,NBPOLY,
C     >      NBLIG,NBCOL,NKCOIN,
C     >      ITVL(ITRAV),NITMAX,
C     >      IDE,ITVL(ITRNOE),NBNMAX,NBE,NBN,NBEMAX,NBPMAX,
C     >      ITRACE,IERRDS)
C
      IF(IERRDS.NE.0)THEN
C        WRITE(6,*) 'ERREUR DANS BLOCOS : ',IERRDS
        GOTO 8888
      ENDIF
C
C        =====================================
C     --- TRANSFERT DES RESULTATS             ---
C        =====================================
C
      NBNN   = 4
      NBREF  = 0
      NBSOUS = 0
      NBELEM = NBE
      SEGINI IPT3
C      write(6,*) 'IPT3 =',IPT3
C     8 = QUA4, 10 = QUA8
      IPT3.ITYPEL = 8
C
      DO 100 I=1,NBE
      DO 100 J=1,NBNN
        IPT3.NUM(J,I) =ITVL((I-1)*NBNMAX+J-1+ITRNOE)+IDEBUT-1
  100 CONTINUE
C      WRITE(6,*)'LE MAILLAGE AVANT SORTIE '
C      WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE)
C      WRITE(6,*) ((ITVL((I-1)*NBNMAX+J-1+ITRNOE),J=1,NBNN),I=1,NBE)
C
C
      ICOORD = 1
      DO 110 I=1,NBN
          XPROJ(1,I+IDEBUT-1) = RTVL((I-1)*IDIMC+ICOORD)
          XPROJ(2,I+IDEBUT-1) = RTVL((I-1)*IDIMC+1+ICOORD)
C         --- IL FAUX REVOIR LE CALCUL DE LA DENSITE ---
          XPROJ(3,I+IDEBUT-1) = RTVL((I-1)*IDIMC+2+ICOORD)
          IF( XPROJ(/1).EQ.4)THEN
            XPROJ(4,I+IDEBUT-1) = RTVL((I-1)*IDIMC+3+ICOORD)
          ENDIF
  110 CONTINUE
      NBN = NBN + IDEBUT-1
C
 8888 CONTINUE
      SEGSUP ITRAVX,RTRAVX
C      write(6,*) 'IPT3 =',IPT3
C      WRITE(6,*)'LE MAILLAGE AVANT SORTIE '
C      WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE)
 9999 END