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 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