Sources Esope | Cast3M

ecubi
C ECUBI     SOURCE    CHAT      05/01/12    23:28:13     5004
      SUBROUTINE ECUBI(SIGMA,DSIGMA,XLAMBD,DEFPLA,YOUNG,XNU,NCRIT,ANG1,
     1 TRA1,PHI1,PSI1,HACHE1,COHE1,CO11,SI11,NCAS,ANG2,TRA2,PHI2,PSI2,
     2 HACHE2,COHE2,CO22,SI22,CO21,SI21,SIGEL,IDAM,KERRE)
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
C
      DIMENSION SIGMA(*),DSIGMA(*),XLAMBD(*),DLAMBD(6),SIGEL(*),
     1 TSOGMA(4),DSOGMA(4),SOGMA(4),TSOG1(4),SOG1(4),DSOG1(4),TSOG2(4),
     2 SOG2(4),DSOG2(4),SIGE(4),ESPPLA(4),DEFPL(4),DEFPLA(*)
C
C----------------------------------------------------------------
C      INITIALISATION DES PARAMATRES
C----------------------------------------------------------------
C
      DLAM1=0.D0
      GAMMA1=0.D0
      GAMMA2=0.D0
      DLAM2=0.D0
      ICHR=0
      ICRI=1
      CALL ZDANUL(DLAMBD,6)
      DO 35 ITYP=1,4
      ESPPLA(ITYP)=0.D0
   35 CONTINUE
      IDAM=0
C
C----------------------------------------------------------------
C     RECUPERATION DU TENSEUR SIGMA ET DSIGMA (COMPOSANTE 1 A 4)
C-----------------------------------------------------------------
C
      DO 100 ITYP=1,4
      TSOGMA(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP)
      SOGMA(ITYP)=SIGMA(ITYP)
      DSOGMA(ITYP)=DSIGMA(ITYP)
  100 CONTINUE
C
C---------------------------------------------------
C     ON CALCULE LA VALEUR DU CRITERE 1
C---------------------------------------------------
C
      CALL CHREPE (CO11,SI11,TSOGMA,TSOG1)
      CALL CHREPE (CO11,SI11,SOGMA,SOG1)
      CALL CHREPE (CO11,SI11,DSOGMA,DSOG1)
      VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1)
C
C ----------------------------------------------
C       ON REGARDE SI ON ENDOMMAGE LE CRITERE 1
C-----------------------------------------------
C
      IF (VCRIT1.LE.0.) GAMMA1=100.D0
      IF (VCRIT1.LE.0.AND.NCRIT.EQ.2) GO TO 200
      IF (VCRIT1.LE.0.AND.NCRIT.EQ.1) GO TO 40000
C
C-----------------------------------------------------------------
C       CALCUL DE GAMMA1 DANS LE CAS OU ON A ENDOMMAGE LE CRITERE1
C-----------------------------------------------------------------
C
      GAMMA1=(COHE1-PHI1*SOG1(2)-SIGN(1.D0,TSOG1(4))*SOG1(4))/
     1 (PHI1*DSOG1(2)+SIGN(1.D0,TSOG1(4))*DSOG1(4))
      IF(IIMPI.EQ.28) WRITE(IOIMP,2979) GAMMA1
      IF(GAMMA1.LE.0.D0) GAMMA1=0.D0
C
C ------------------------------------------------------
C         CAS OU ON A UN SEUL CRITERE (ON VA EN 5000)
C ------------------------------------------------------
C
      IF(IIMPI.EQ.28) WRITE(IOIMP,2979) GAMMA1
 2979 FORMAT( '0 ECUBI  GAMMA1 =',1PE12.5/)
      IF(NCRIT.EQ.1) GO TO 5000
C
C---------------------------------
C       CALCUL DU CRITERE 2
C---------------------------------
C
  200 CALL CHREPE(CO22,SI22,TSOGMA,TSOG2)
      CALL CHREPE(CO22,SI22,DSOGMA,DSOG2)
      CALL CHREPE(CO22,SI22,SOGMA,SOG2)
      VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2)
C
C---------------------------------------------------
C       ON REGARDE SI ON ENDOMMAGE LE CRITERE 2
C---------------------------------------------------
C
      IF (VCRIT2.LE.0.D0) GAMMA2=100.D0
      IF (VCRIT2.LE.0.D0) GOTO 300
C
C-----------------------------------------------------------------
C       CALCUL DE GAMMA2 DANS LE CAS OU ON A ENDOMMAGE LE CRITERE2
C-----------------------------------------------------------------
C
      GAMMA2=(COHE2-PHI2*SOG2(2)-SIGN(1.D0,TSOG2(4))*SOG2(4))/
     1 (PHI2*DSOG2(2)+SIGN(1.D0,TSOG2(4))*DSOG2(4))
      IF(IIMPI.EQ.28) WRITE(IOIMP,3979) GAMMA2
      IF(GAMMA2.LE.0.D0) GAMMA2=0.D0
      IF(IIMPI.EQ.28) WRITE(IOIMP,3979) GAMMA2
 3979 FORMAT( '0 ECUBI  GAMMA2 =',1PE12.5/)
C
C-----------------------------------------------------------
C       ON REGARDE QUEL CRITERE EST ENDOMMAGE LE PREMIER
C-----------------------------------------------------------
C
  300 GAMMA=MIN(GAMMA1,GAMMA2)
C
C-----------------------------------------------------------
C    GAMMA PLUS GRAND QUE 1 AUCUN CRITERE N'EST ENDOMMAGE
C-----------------------------------------------------------
C
      IF (GAMMA.GE.1.D0) GO TO 40000
C
C ------------------------------------------------------------
C    GAMMA1 ET GAMMA2 PLUS PETITS QUE 1.D-5 OU GAMMA1=GAMMA2
C        ON EST DANS LE CAS DU COUPLAGE
C ------------------------------------------------------------
C
      IF (GAMMA1.EQ.0.D0.AND.GAMMA2.EQ.0.D0) GO TO 30001
      GAM=MAX(GAMMA1,GAMMA2)
      IF (GAM.LT.1.D-5) GOTO 30001
      POURCE=ABS((GAMMA1-GAMMA2)/(GAMMA1+GAMMA2))
      IF (POURCE.LE.1.D-4) GO TO 30001
C
C-----------------------------------------------------------------
C GAMMA1 PLUS PETIT QUE GAMMA2 LE CRITERE 1 EST ENDOMMAGE PREMIER
C-----------------------------------------------------------------
C
      IF (GAMMA1.LT.GAMMA2) GO TO 10000
C
C-----------------------------------------------------------------
C GAMMA1 PLUS PETIT QUE GAMMA2 LE CRITERE 1 EST ENDOMMAGE PREMIER
C-----------------------------------------------------------------
C
      IF (GAMMA2.LT.GAMMA1) GO TO 20000
C
C----------------------------------------------------
C           ECOULEMENT QUAND ON A UN SEUL CRITERE
C----------------------------------------------------
C
 5000 CALL ECUBI1(SOG1,DSOG1,GAMMA1,PHI1,PSI1,NCAS,TRA1,XNU,YOUNG,
     1 COHE1,SIGE,ESPPLA,DLAM1,CO11,SI11,HACHE1,IDAM,KERRE)
       GO TO 50000
C
C-------------------------------------------------------
C     ECOULEMENT SUIVANT CRITERE 1 (CAS DE 2 CRITERES)
C-------------------------------------------------------
C
10000 CALL ECUBI2(SOG1,DSOG1,GAMMA1,PHI1,PSI1,NCAS,TRA1,
     1 XNU,YOUNG,COHE1,HACHE1,CO11,SI11,
     2 PHI2,PSI2,COHE2,CO22,SI22,HACHE2,TRA2,
     3 CO21,SI21,SIGE,ESPPLA,DLAM1,ICHR,SOGMA,DSOGMA,KERRE)
      IF(IIMPI.EQ.28) WRITE(IOIMP,3333)
 3333 FORMAT( '0 ON EST PASSE PAR CRIT 1')
C
C---------------------------------------------
C    ICHR=1 ON VA AVOIR 1 CAS DE COUPLAGE
C---------------------------------------------
C
      IF(ICHR.EQ.0) IDAM=1
      IF(ICHR.EQ.0) GO TO 50000
      ICRI=1
      GO TO 30000
C
C--------------------------------------
C     ECOULEMENT SUIVANT CRITERE 2
C--------------------------------------
C
20000 CALL ECUBI2(SOG2,DSOG2,GAMMA2,PHI2,PSI2,NCAS,TRA2,
     1 XNU,YOUNG,COHE2,HACHE2,CO22,SI22,
     2 PHI1,PSI1,COHE1,CO11,SI11,HACHE1,TRA1,
     3 CO21,-SI21,SIGE,ESPPLA,DLAM2,ICHR,SOGMA,DSOGMA,KERRE)
      IF(IIMPI.EQ.28) WRITE(IOIMP,4333)
 4333 FORMAT( '0 ON EST PASSE PAR CRIT 2')
      IF(ICHR.EQ.0) IDAM=2
      IF(ICHR.EQ.0) GO TO 50000
C
C---------------------------------------------
C    ICHR=1 ON VA AVOIR 1 CAS DE COUPLAGE
C---------------------------------------------
C
      ICRI=2
      GO TO 30000
C
C----------------------------------------------
C    CAS OU AUCUN CRITERE N'EST ENDOMMAGE
C----------------------------------------------
C
40000 DO 55 ITYP=1,6
      SIGEL(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP)
      DLAMBD(ITYP)=0.D0
   55 CONTINUE
      GO TO 165
C
C
30001 DO 23 ITYP=1,4
      SOGMA(ITYP)=SOGMA(ITYP)+GAMMA*DSOGMA(ITYP)
      DSOGMA(ITYP)=(1.D0-GAMMA)*DSOGMA(ITYP)
   23 CONTINUE
30000 CONTINUE
      IF(IIMPI.EQ.28) WRITE(IOIMP,5333)
 5333 FORMAT( '0 ON EST PASSE PAR COUPLA')
      CALL CHREPE (CO11,SI11,SOGMA,TSOG1)
      VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1)
      CALL CHREPE (CO22,SI22,SOGMA,TSOG2)
      VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2)
      IF(IIMPI.EQ.28) WRITE(IOIMP,1978) VCRIT1
      IF(IIMPI.EQ.28) WRITE(IOIMP,1979) VCRIT2
      CALL ECUBIC(SOGMA,DSOGMA,COHE1,COHE2,CO11,SI11,
     1 CO22,SI22,CO21,SI21,TRA1,TRA2,YOUNG,XNU,DEFPL,SIGE,IDAM,
     2 DLAM1,DLAM2,PSI1,PHI1,PSI2,PHI2,NCAS,ICRI,HACHE1,HACHE2,KERRE)
      IF(IIMPI.EQ.28) WRITE(IOIMP,1980)
 1980 FORMAT( 'ON A APPELLE LE COUPLAGE')
      DO 174 ITYP=1,4
      ESPPLA(ITYP)=DEFPL(ITYP)+ESPPLA(ITYP)
  174 CONTINUE
      GO TO 50000
C
C---------------------------------------------------------------
C     ON REMPLIT LE TABLEAU SIGEL ET DLAMBD ET XLAMBD ET DEFPLA
C---------------------------------------------------------------
C
50000 DO 21 ITYP=1,4
      SIGEL(ITYP)=SIGE(ITYP)
      DSOGMA(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP)-SIGEL(ITYP)
      DEFPLA(ITYP)=ESPPLA(ITYP)
   21 CONTINUE
      SIGEL(5)=DSIGMA(5)+SIGMA(5)
      SIGEL(6)=DSIGMA(6)+SIGMA(6)
      DEFPLA(5)=0.D0
      DEFPLA(6)=0.D0
      CALL CHREPE(CO11,SI11,DSOGMA,DSOG1)
      CALL CHREPE(CO22,SI22,DSOGMA,DSOG2)
      IF(NCAS.EQ.1) CALL CPCONT(DSOG1,SOG1,XNU,YOUNG)
      IF(NCAS.EQ.1) CALL CPCONT(DSOG2,SOG2,XNU,YOUNG)
      IF(NCAS.NE.1) CALL DPCONT(DSOG1,SOG1,XNU,YOUNG)
      IF(NCAS.NE.1) CALL DPCONT(DSOG2,SOG2,XNU,YOUNG)
      DLAMBD(1)=SOG1(2)
      DLAMBD(3)=SOG2(2)
      DLAMBD(2)=SOG1(4)*2.D0
      DLAMBD(4)=SOG2(4)*2.D0
      DLAMBD(5)=DLAM1
      DLAMBD(6)=DLAM2
      DO 333 ITYP=1,6
      XLAMBD(ITYP)=XLAMBD(ITYP)+DLAMBD(ITYP)
  333 CONTINUE
  165 CALL CHREPE (CO11,SI11,SIGEL,TSOG1)
      VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1)
      CALL CHREPE (CO22,SI22,SIGEL,TSOG2)
      VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2)
      IF(IIMPI.EQ.28) WRITE(IOIMP,1978) VCRIT1
 1978 FORMAT( '0 ECUBI  VCRIT1 =',1PE12.5/)
      IF(IIMPI.EQ.28) WRITE(IOIMP,1979) VCRIT2
 1979 FORMAT( '0 ECUBI  VCRIT2 =',1PE12.5/)
      RETURN
      END