Sources Esope | Cast3M

tractt
C TRACTT    SOURCE    CHAT      05/01/13    03:44:25     5004
 
      SUBROUTINE TRACTT(COURB,NPTEUR,TRAC,NCOURB,NC,NNFUS,T)
C
C
C---------------------------------------------------------------------
C Objet:
C -----
C  Ce sous-programme determine la courbe de traction a la temp.T
C  a partir de celles aux temperatures TINF et TSUP qui encadrent
C  T.Il utilise le sous-programme FUSION qui effectue la fusion
C  des 2 courbes de traction definies aux temperatures TINF et
C  TSUP,TINF &lt; T &lt; TSUP.
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C Entrees:
C -------
C NPTEUR(NC) = tableau contenant les nombres de points de discretisation
C              pour chaque courbe a T fixee.
C              Ex: si NPTEUR(1)=20 alors pour la valeur T=T1 la fonction
C              Y=F(X,T1) est discretisee sur 20 points.
C NC         = nombre de courbes connues pour T1,T2,....
C NCOURB     = dimension du tableau COURB
C COURB(NCOURB) = tableau contenant les courbes de traction a differentes
C                 temperatures T1,T2,T3,...
C X,T        = point et parametre d'interpolation.
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C Sorties:
C -------
C NNFUS       = dimension du tableau TRAC.
C TRAC(NNFUS)= courbe de traction a la temperature T;c'est la courbe
C               (espp,sigma).
C---------------------------------------------------------------------
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION NPTEUR(*),COURB(*),COURB1(260),COURB2(260)
      DIMENSION FUS1(520),FUS2(520),TRAC(*)
 
      EPS1 = 1.D-8
 
C
C--------------------------------------
C Courbe independante de la temperature
C--------------------------------------
      IF (NC.EQ.1) THEN
                        TINF=T
                        TSUP=T
                        LTINF=0
                        LTSUP=0
                        NPTINF=NPTEUR(1)
                        NPTSUP=NPTEUR(1)
                        GOTO 100
      ENDIF
C
C------------------------------------------------------
C Recherche des temperatures extremes connues TMIN,TMAX
C------------------------------------------------------
      TMIN=COURB(1)
      KT=0
      DO 5 I=1,NC-1
5     KT=KT+NPTEUR(I)
      KT=2*KT
      KT=KT+NC
      TMAX=COURB(KT)
C
C---------------------------------------------------------------------
C T plus petit que la plus petite des temperatures ou plus grande que
C               la plus grande des temperatures
C---------------------------------------------------------------------
      IF (T.LT.TMIN) THEN
                         TINF=T
                         TSUP=T
                         LTINF=1
                         LTSUP=1
                         NPTINF=NPTEUR(1)
                         NPTSUP=NPTEUR(1)
                         GOTO 100
      ENDIF
      IF (T.GT.TMAX) THEN
                         TINF=T
                         TSUP=T
                         LTINF=KT
                         LTSUP=KT
                         NPTINF=NPTEUR(NC)
                         NPTSUP=NPTEUR(NC)
                         GOTO 100
      ENDIF
C
C---------------------------------------------------------------------
C Recherche de l'intervalle de temperature [TINF,TSUP] comprenant T
C---------------------------------------------------------------------
      I=1
      KC=1
30    CONTINUE
      NPTINF=NPTEUR(KC)
      IF ( T.LT.COURB(I+2*NPTINF+1) ) THEN
          LTINF=I
          LTSUP=I+2*NPTINF+1
          TINF=COURB(LTINF)
          TSUP=COURB(LTSUP)
          NPTSUP=NPTEUR(KC+1)
          GOTO 100
        ELSE
          I=I+2*NPTINF+1
          KC=KC+1
          GOTO 30
      ENDIF
C
100   CONTINUE
C
C--------------------------------------------------------------------
C Sauvegarde des courbes de F(X,T) pour TINF et TSUP
C--------------------------------------------------------------------
      N1=2*NPTINF
      DO 50 J=1,N1
50    COURB1(J)=COURB(J+LTINF)
C
      N2=2*NPTSUP
      DO 60 J=1,N2
60    COURB2(J)=COURB(J+LTSUP)
C
C---------------------------------------------------------------------
C calcul des courbes de F(X,TINF) et de F(X,TSUP) pour les abscisses
C completes i.e. pour la reunion des abscisses moins leur intersection
C----------------------------------------------------------------------
      CALL FUS(COURB1,COURB2,FUS1,FUS2,NPTINF,NPTSUP,NFUS)
C
C----------------------------------------------------------------------
C Les courbes de F(X,TINF) et de F(X,TSUP) ayant maintenant les memes
C abscisses,on pretend la chose suivante :
C si l'on a la relation T=(1-teta)TINF+(teta)TSUP , alors on ecrit
C F(X,T) = (1-TETA)F(X,TINF) + (TETA)F(X,TSUP)
C----------------------------------------------------------------------
      IF (TINF.EQ.TSUP) THEN
          TETA=0.
        ELSE
          TETA=(T-TINF)/(TSUP-TINF)
      ENDIF
      DO 88 M=1,2*NFUS-1,2
         TRAC(M)=FUS1(M)
         TRAC(M+1)=(1-TETA)*FUS1(M+1)+TETA*FUS2(M+1)
88    CONTINUE
 
C
C---------------------------------------------------------------------
C determination de la courbe (epsp,sigma) à T à partir de la courbe
C (eps,sigma) à T
C---------------------------------------------------------------------
 
      DE=TRAC(4)/TRAC(3)
      NNFUS=NFUS-1
      DO 27 I=1,2*NNFUS-1,2
        TRAC(I)=TRAC(I+2)-TRAC(I+3)/DE
        TRAC(I+1)=TRAC(I+3)
27    CONTINUE
 
C Suppression des doublons
 
      I1 = 1
29    CONTINUE
      IF (I1.GE.NNFUS) GOTO 31
      XI = ABS(TRAC(I1) - TRAC(I1+2))
      EPS2 = (ABS ( MIN(TRAC(I1),TRAC(I1+2)) ))*EPS1
      IF ( (XI.LE.EPS2) .OR.
     *   ( (TRAC(I1).LE.EPS1).AND.(TRAC(I1+2).LE.EPS1))) THEN
        DO 28 I=I1,2*NNFUS-1,2
          TRAC(I)=TRAC(I+2)
          TRAC(I+1)=TRAC(I+3)
28      CONTINUE
        NNFUS=NNFUS - 1
      ELSE
        I1 = I1 + 2
      ENDIF
      GOTO 29
31    CONTINUE
 
C Mise à zero du premier point si necessaire
 
      TRAC(1)=0.D0
C
      END
C*********************************************************************