Télécharger crpha4.eso

Retour à la liste

crpha4
C CRPHA4    SOURCE    PV        17/12/08    21:17:07     9660           
C====================================================================
C
      SUBROUTINE CRPHA4(VWRK1,CARB,iwrk52,IMARQ,DTPS,VWRK2,nhist,
     .ilent1,ilent2,iele,igau)
C
C====================================================================
C
C     Calcul de transformations de phases
C     appelee par CRPHA3
C
C     calcule les nouvelles proportions de phases au point considere
C
C     vwrk1 /1 temperature
C           /2 vitesse de chauf,refr
C           /3 proportion d'austenite
C           /4 proportion de ferrite
C           /5 proportion de bainite
C           /6 proportion de martensite
C           /7 temperature de debut de transf. martensitique
C     carb     taux de carbone moyen
C     iptab    donnees materiau
C     imarq    indicateur pour le tri des donnees
C     dtps     pas de temps
C     vwrk2    resultat : vwrk1 actualise
C
C     routines appelees
C     1)austenitisation
C          TRITE3       tri dans la table des temperatures
C          AUSTRK       integration de l'equa diff de Leblond
C                       (runge-kutta ordre 4)
C     2)ferrite+bainite
C          VOISI2      recherche des point support de l'interpolation
C          INTER9       interpolation/extrapolation
C
C       Michael Martinez 12/98
C====================================================================
C
C     Modifications de LB a partir du 15/03/97
C     ========================================
C      1) verifie que les compositions restent positives
C      3) prise en compte de la vitesse mini pour l apparition
C         de la martensite
C
      IMPLICIT INTEGER(I-N)
       IMPLICIT REAL*8(A-H,O-Z)
C
-INC SMNUAGE
-INC SMLENTI
-INC SMLREEL
 
-INC DECHE
C
      REAL*8 VWRK1(*),VWRK2(7),ZFIN(4),VOIS2(4,3),COEF2(4)
      REAL*8 TZFP(4),TZBP(4),CK(10),CL(10),TE(10)
      INTEGER IMARQ(2)
C
      DATA SMALL /0.000001/, PRESQU_UN /0.99999999/
C
      wrk52 = iwrk52
      T0=VWRK1(1)
      TP0=VWRK1(2)
      ZA0=VWRK1(3)
      VMS1=VWRK1(7)
              if (iele.eq.1. and.igau.eq.1) then
*        write(6,*) 'trpha2 0',T0,TP0,ZA0,VMS1
           endif
C
C    ON RESTE DANS DES LIMITES RAISONNABLES
C
        IF (T0.GT.999.) THEN
           VWRK2(1)=VWRK1(1)
           VWRK2(2)=VWRK1(2)
           VWRK2(3)=1.D0
           VWRK2(4)=0.D0
           VWRK2(5)=0.D0
           VWRK2(6)=0.D0
           VWRK2(7)=VWRK1(7)
           RETURN
        ENDIF
C
C   LECTURE DES DONNEES DE LA TABLE : AR1, MS0 ...
C
          AC1=xmat0(1)
          AR1=xmat0(2)
          VMS0=xmat0(3)
          BETA=xmat0(4)
          AC=xmat0(5)
          AA=xmat0(6)
          ZS=xmat0(7)
          TPLM=xmat0(8)
          CARB0=xmat0(9)
 
        mnuag1 = int(xmat0(17))
 
c        NCHAUF=NHIST+3
C
      IF (abs(TP0).LT.abs(TPLM)) then
        VMS1 = 210.
      ENDIF
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF ((T0.GT.AR1.AND.ZA0.LT.PRESQU_UN).OR.(TP0.GE.0..AND.T0.GE.AC1
     .    .AND.ZA0.LT.PRESQU_UN)) THEN
C
C    AUSTENITISATION (MODELE DE LEBLOND)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C    POSITIONNEMENT EN TEMPERATURE
C
        T1=T0+TP0*DTPS
        mlenti = ilent2
        segact mlenti
        ntemp = lect(/1)
        ITEMP0=IMARQ(1)
        ITEMP1=IMARQ(1)
        CALL TRITE3 (ilent2,NTEMP,T0,ITEMP0,ITSUP)
        CALL TRITE3 (ilent2,NTEMP,T1,ITEMP1,ITSUP)
        IMARQ(1)=ITEMP0
C
C    RECUPERATION DES DEUX COEF DU MODELE DE LEBLOND
C
        segact mlenti
        mlree1 = lect(itemp0)
        mlree2 = lect(itemp1)
        segact mlree1,mlree2
              CKA0=mlree1.prog(2)
              CLA0=mlree1.prog(3)
 
              CKA1=mlree2.prog(2)
              CLA1=mlree2.prog(3)
        segdes mlree1,mlree2
 
C    AUSTENITISATION
C
         CALL AUSTRK(VWRK1,ZFIN,CKA0,CKA1,CLA0,CLA1,DTPS)
C
         VWRK2(1)=T0
         VWRK2(2)=TP0
         VWRK2(3)=ZFIN(1)
         VWRK2(4)=ZFIN(2)
         VWRK2(5)=ZFIN(3)
         VWRK2(6)=ZFIN(4)
         VWRK2(7)=VMS0-AC*(CARB-CARB0)
C
      ELSE
              if (iele.eq.1. and.igau.eq.1) then
*        write(6,*) 'trpha2 11'
                endif
        VWRK2(1)=VWRK1(1)
        VWRK2(2)=VWRK1(2)
        VWRK2(3)=VWRK1(3)
        VWRK2(4)=VWRK1(4)
        VWRK2(5)=VWRK1(5)
        VWRK2(6)=VWRK1(6)
        VWRK2(7)=VWRK1(7)
C
      ENDIF
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (TP0.GE.0..AND.T0.LT.AC1) THEN
C
C  CHAUFFAGE EN DESSOUS DE AC1 --> PAS DE TRANSFORMATIONS
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        VWRK2(1)=VWRK1(1)
        VWRK2(2)=VWRK1(2)
        VWRK2(3)=VWRK1(3)
        VWRK2(4)=VWRK1(4)
        VWRK2(5)=VWRK1(5)
        VWRK2(6)=VWRK1(6)
        VWRK2(7)=VWRK1(7)
C
      ENDIF
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (TP0.LT.0..AND.T0.LE.AR1.AND.T0.GT.VMS1) THEN
C
C    TRANSFORMATION AUSTENITE --> FERRITE + BAINITE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
               if (iele.eq.1. and.igau.eq.1) then
*       write(6,*) 'trpha2 3'
             endif
C
C    IL N'Y A DE TRANSFORMATION
C    QUE POUR UN MATERIAU CONTENANT DE L'AUSTENITE
C
        IF (VWRK1(3).LT.SMALL) THEN
          VWRK2(1)=VWRK1(1)
          VWRK2(2)=VWRK1(2)
          VWRK2(3)=VWRK1(3)
          VWRK2(4)=VWRK1(4)
          VWRK2(5)=VWRK1(5)
          VWRK2(6)=VWRK1(6)
          VWRK2(7)=VWRK1(7)
        ELSE
C
C    (FIN MODIF MM)
C
C    -->  RECHERCHE DES VOISINS
C    ON COMMENCE PAR ENCADRER LA TEMPERATURE T0
C    SUR LA PREMIERE COURBE
C
C    INITIALISATION DE VOIS2
C
          VOIS2(1,1)=0
          VOIS2(2,1)=0
          VOIS2(3,1)=0
          VOIS2(4,1)=0
          VOIS2(1,2)=0.D0
          VOIS2(2,2)=0.D0
          VOIS2(3,2)=0.D0
          VOIS2(4,2)=0.D0
          VOIS2(1,3)=100000.D0
          VOIS2(2,3)=100000.D0
          VOIS2(3,3)=100000.D0
          VOIS2(4,3)=100000.D0
C
C    DETERMINATION DES QUATRES POINTS LES PLUS PROCHES
C    (==> VOIS2)
C
          CALL VOISI2(T0,TP0,ZA0,VOIS2,IMARQ,ilent1,iele,igau)
              if (iele.eq.1. and.igau.eq.1) then
*                 write(6,*) t0,tp0,za0
              endif
C
C     INTERPOLATION A PARTIR DE VOIS2
C
          CALL INTER9(T0,TP0,ZA0,VOIS2,COEF2,ilent1)
C
          MLENTI = ILENT1
          segact mlenti
C
          DO 1002 I=1,4
            IHIST=nint(VOIS2(I,1))
            mlent1 = lect(ihist)
            segact mlent1
              ITEMP=nint(VOIS2(I,2))
              mlreel = mlent1.lect(itemp)
              segact mlreel
              za = prog(3)
              zf = prog(4)
              zb = prog(5)
              zfp = prog(8)
              zbp = prog(9)
                  tk = prog(1)
                  tkp = prog(2)
              if (iele.eq.1. and.igau.eq.1) then
*                  write(6,*) 'yo', i,ihist,itemp
*                 write(6,*) tk,tkp,za, zf
                endif
                 IF (ZA.LT.SMALL) THEN
                  TZFP(I) = 0
                  TZBP(I) = 0
                ELSE
                  TZFP(I)=ZFP/ZA
                  TZBP(I)=ZBP/ZA
                ENDIF
            segdes mlreel,mlent1
 1002     CONTINUE
C
          segdes mlenti
C
          TZFP0=COEF2(1)*TZFP(1)+COEF2(2)*TZFP(2)+COEF2(3)*TZFP(3)
     &         +COEF2(4)*TZFP(4)
          TZBP0=COEF2(1)*TZBP(1)+COEF2(2)*TZBP(2)+COEF2(3)*TZBP(3)
     &         +COEF2(4)*TZBP(4)
          ZFP0=TZFP0*ZA0
          ZBP0=TZBP0*ZA0
C
          VWRK2(1)=VWRK1(1)
          VWRK2(2)=VWRK1(2)
          VWRK2(4)=VWRK1(4)+ZFP0*DTPS
          VWRK2(5)=VWRK1(5)+ZBP0*DTPS
C
C  MODIF DE LB :
C
C  CONTROLE POUR BAINITE OU FERRITE POSITIVE
C
          IF (VWRK2(4).LT.0.0) THEN
            VWRK2(4) = 0.0
          ENDIF
          IF (VWRK2(5).LT.0.0) THEN
            VWRK2(5) = 0.0
          ENDIF
C
C  CONTROLE POUR GARDER AUSTENITE POSITIVE :
C  on verifie que BAINITE + FERRITE <= 1
C
C  si creation de ferrite
C
          IF (ZFP0.GT.ZBP0) THEN
            IF ((VWRK2(4)+VWRK2(5)).GT.1.0) THEN
              VWRK2(4) = 1.0 - VWRK2(5)
            ENDIF
C
C  si creation de bainite
C
          ELSE IF ((VWRK2(4)+VWRK2(5)).GT.1.0) THEN
            VWRK2(5) = 1.0 - VWRK2(4)
          ENDIF
C
C  FIN MODIF LB
C
          VWRK2(3)=1.D0-(VWRK2(4)+VWRK2(5))
          VWRK2(6)=VWRK1(6)
C
C  TEMPERATURE DE DEBUT DE TRANSF. MARTENSITIQUE
C
          ZTRSF = 1. - VWRK2(3)
          DZ = ZTRSF - ZS
          IF (DZ.LT.0.D0) THEN
            DZ=0.D0
          ENDIF
          VWRK2(7)=VMS0-AC*(CARB-CARB0)-AA*DZ
C
        ENDIF
C
      ENDIF
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (TP0.LT.0..AND.T0.LE.VMS1) THEN
C
C    TRANSFORMATION MARTENSITIQUE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        VWRK2(7)=VWRK1(7)
        VWRK2(5)=VWRK1(5)
        VWRK2(4)=VWRK1(4)
        VWRK2(2)=VWRK1(2)
        VWRK2(1)=VWRK1(1)
C
C   CALCUL DU TAUX DE MARTENSITE (AVEC IRREVERSIBILITE)
C
        ZAN=1.D0-(VWRK1(4)+VWRK1(5))
        DELTT=VMS1-T0
        ZM1=VWRK1(6)
        ZM2=ZAN*(1.D0-EXP(BETA*DELTT))
        IF (ZM2.GT.ZM1) THEN
          VWRK2(6)=ZM2
        ELSE
          VWRK2(6)=ZM1
        ENDIF
C
C   FIN MODIF MM
C
        tem_00 = BETA * DELTT
C
C   MODIF DE LB
C
C   POUR GARDER L'AUSTENITE POSITIVE
C
        IF ((VWRK2(4)+VWRK2(5)+VWRK2(6)).GE.1.0) THEN
          VWRK2(6) = 1.d0 - (VWRK2(4)+VWRK2(5))
          VWRK2(3) = 0.d0
        ELSE
          VWRK2(3)=1.0D0 - (VWRK2(4)+VWRK2(5)+VWRK2(6))
        ENDIF
C
C  FIN MODIF LB
C
      ENDIF
C
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales