Sources Esope | Cast3M

decoup
C DECOUP    SOURCE    GOUNAND   25/08/18    21:15:02     12341          
C  CALCUL AUTOMATIQUE DES DECOUPAGES
C
      SUBROUTINE DECOUP(INBR,DEN1,DEN2,APROG,NBELEM,DENI,DECA,DLONG)
C***********************************************************************
C Quelques commentaires (gounand, 2025/08)
C ENTREES            : INBR  : nombre d'elements demandes
C                        >0  : decoupage regulier de l'intervalle
C                        0   : decoupage en progression geometrique de
C                              raison APROG
C                        &lt;0  : decoupage en progression geometrique de
C                              meme raison APROG mais avec un nombre
C                              d'elements fixe a -INBR
C                      DEN1  : taille normalisee au 1er noeud
C                              = taille / longueur de l'intervalle
C                      DEN2  : taille normalisee au dernier noeud
C                      DLONG : Longueur de l'intervalle a decouper
C SORTIES            : DEN1  : taille du 1er element de l'intervalle
C                      APROG : raison de la progression geometrique
C                      NBELEM: nombre d'elements de l'intervalle
C                      DENI  : taille au premier noeud
C                      DECA  : taille au dernier noeud - DENI
C Note : les tailles au noeud et les tailles d'elements suivent une
C        progression geometrique de meme raison mais avec un decalage
C        (facteur multiplicatif) de sqrt(raison) (probleme des piquets
C        et des intervalles). Voir aussi : ligne.dgibi
C Attention : DEN1, argument d'entree/sortie
C***********************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL LPROG
-INC CCREEL
**    DEN1=SIGN(MAX(XPETIT,ABS(DEN1)),DEN1)
**    DEN2=SIGN(MAX(XPETIT,ABS(DEN2)),DEN2)
      DEN1=MAX(XPETIT,ABS(DEN1))
      DEN2=MAX(XPETIT,ABS(DEN2))
C     write(6,*) 'INBR,DEN1,DEN2=',INBR,DEN1,DEN2
      IF ((INBR.EQ.0).AND.(ABS(DEN1).LT.XPETIT.OR.ABS(DEN2).LT.XPETIT))
     > THEN
         CALL ERREUR(809)
         RETURN
      ENDIF
      IF (INBR.GT.0) THEN
         APROG =1.D0
         NBELEM=INBR
         DEN1  =1.D0/INBR
         DENI  =DLONG/INBR
         DECA  =0.D0
      ELSE
         IF (SIGN(1.D0,DEN1)*SIGN(1.D0,DEN2).LE.0.D0) THEN
            CALL ERREUR(809)
            RETURN
         ENDIF
*
         XAUX=abs(((DEN1-DEN2)**2)/2)
         IF (DEN2.LT.DEN1) THEN
            APROG=1.D0+XAUX-SQRT(XAUX*(2+XAUX))
         ELSE
            APROG=1.D0+XAUX+SQRT(XAUX*(2+XAUX))
         ENDIF
         IF (ABS(APROG).LT.XPETIT) THEN
           CALL ERREUR(809)
           RETURN
         ENDIF
         LPROG=((ABS(APROG-1))   .GT.  1.D-5)
C     write(6,*) 'XAUX,APROG =',XAUX,APROG
         IF (INBR.LT.0) THEN
            NBELEM=-INBR
         ELSE
            IF (LPROG) THEN
*sg 2019/07 eviter les pbs si DEN2/DEN1 est trop grand
*sg      XNBELE=(LOG(DEN2/DEN1)/LOG(APROG))
               XNBELE=(LOG(ABS(DEN2))-LOG(ABS(DEN1)))/(LOG(APROG))
            ELSE
               XNBELE=min(1.D0/DEN1,dble(igrand))
               XNBELE=max(xnbele,-2.d0**31)
            ENDIF
            if(.not.(xnbele.ge.xpetit)) xnbele=xpetit
            NBELEM=INT(XNBELE)
            NBELEM=MAX(1,NBELEM)
            IF (XNBELE/NBELEM.GT.(NBELEM+1)/XNBELE) NBELEM=NBELEM+1
         ENDIF
         IF (LPROG) THEN
            DEN1=(1.D0-APROG)/((1.D0-APROG**NBELEM)*APROG)
         ELSE
            DEN1=1.D0/REAL(NBELEM)
         ENDIF
         DENI=DEN1*DLONG*SQRT(APROG)
         DENF=DENI*(APROG**NBELEM)
*dbg         write(6,*) 'DENI,DENF=',DENI,DENF
         DECA=DENF-DENI
      ENDIF
*      write(6,*) ' decoup nbelem deni deca',nbelem,deni,deca
*      if (deni.LE.xzprec) write(6,*) ' deni &lt; xzprec'
      if (nbelem.GT.igranD) nbelem=1
      RETURN
      END