1 : C ECUBI SOURCE CHAT 05/01/12 23:28:13 5004 2 : SUBROUTINE ECUBI(SIGMA,DSIGMA,XLAMBD,DEFPLA,YOUNG,XNU,NCRIT,ANG1, 3 : 1 TRA1,PHI1,PSI1,HACHE1,COHE1,CO11,SI11,NCAS,ANG2,TRA2,PHI2,PSI2, 4 : 2 HACHE2,COHE2,CO22,SI22,CO21,SI21,SIGEL,IDAM,KERRE) 5 : C 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8(A-H,O-Z) 8 : -INC CCOPTIO 9 : C 10 : DIMENSION SIGMA(*),DSIGMA(*),XLAMBD(*),DLAMBD(6),SIGEL(*), 11 : 1 TSOGMA(4),DSOGMA(4),SOGMA(4),TSOG1(4),SOG1(4),DSOG1(4),TSOG2(4), 12 : 2 SOG2(4),DSOG2(4),SIGE(4),ESPPLA(4),DEFPL(4),DEFPLA(*) 13 : C 14 : C---------------------------------------------------------------- 15 : C INITIALISATION DES PARAMATRES 16 : C---------------------------------------------------------------- 17 : C 18 : DLAM1=0.D0 19 : GAMMA1=0.D0 20 : GAMMA2=0.D0 21 : DLAM2=0.D0 22 : ICHR=0 23 : ICRI=1 23 : CALL ZDANUL(DLAMBD,6) 24 : DO 35 ITYP=1,4 25 : ESPPLA(ITYP)=0.D0 26 : 35 CONTINUE 27 : IDAM=0 28 : C 29 : C---------------------------------------------------------------- 30 : C RECUPERATION DU TENSEUR SIGMA ET DSIGMA (COMPOSANTE 1 A 4) 31 : C----------------------------------------------------------------- 32 : C 33 : DO 100 ITYP=1,4 34 : TSOGMA(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP) 35 : SOGMA(ITYP)=SIGMA(ITYP) 36 : DSOGMA(ITYP)=DSIGMA(ITYP) 37 : 100 CONTINUE 38 : C 39 : C--------------------------------------------------- 40 : C ON CALCULE LA VALEUR DU CRITERE 1 41 : C--------------------------------------------------- 42 : C 42 : CALL CHREPE (CO11,SI11,TSOGMA,TSOG1) 42 : CALL CHREPE (CO11,SI11,SOGMA,SOG1) 42 : CALL CHREPE (CO11,SI11,DSOGMA,DSOG1) 43 : VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1) 44 : C 45 : C ---------------------------------------------- 46 : C ON REGARDE SI ON ENDOMMAGE LE CRITERE 1 47 : C----------------------------------------------- 48 : C 49 : IF (VCRIT1.LE.0.) GAMMA1=100.D0 50 : IF (VCRIT1.LE.0.AND.NCRIT.EQ.2) GO TO 200 51 : IF (VCRIT1.LE.0.AND.NCRIT.EQ.1) GO TO 40000 52 : C 53 : C----------------------------------------------------------------- 54 : C CALCUL DE GAMMA1 DANS LE CAS OU ON A ENDOMMAGE LE CRITERE1 55 : C----------------------------------------------------------------- 56 : C 57 : GAMMA1=(COHE1-PHI1*SOG1(2)-SIGN(1.D0,TSOG1(4))*SOG1(4))/ 58 : 1 (PHI1*DSOG1(2)+SIGN(1.D0,TSOG1(4))*DSOG1(4)) 59 : IF(IIMPI.EQ.28) WRITE(IOIMP,2979) GAMMA1 60 : IF(GAMMA1.LE.0.D0) GAMMA1=0.D0 61 : C 62 : C ------------------------------------------------------ 63 : C CAS OU ON A UN SEUL CRITERE (ON VA EN 5000) 64 : C ------------------------------------------------------ 65 : C 66 : IF(IIMPI.EQ.28) WRITE(IOIMP,2979) GAMMA1 67 : 2979 FORMAT( '0 ECUBI GAMMA1 =',1PE12.5/) 68 : IF(NCRIT.EQ.1) GO TO 5000 69 : C 70 : C--------------------------------- 71 : C CALCUL DU CRITERE 2 72 : C--------------------------------- 73 : C 73 : 200 CALL CHREPE(CO22,SI22,TSOGMA,TSOG2) 73 : CALL CHREPE(CO22,SI22,DSOGMA,DSOG2) 73 : CALL CHREPE(CO22,SI22,SOGMA,SOG2) 74 : VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2) 75 : C 76 : C--------------------------------------------------- 77 : C ON REGARDE SI ON ENDOMMAGE LE CRITERE 2 78 : C--------------------------------------------------- 79 : C 80 : IF (VCRIT2.LE.0.D0) GAMMA2=100.D0 81 : IF (VCRIT2.LE.0.D0) GOTO 300 82 : C 83 : C----------------------------------------------------------------- 84 : C CALCUL DE GAMMA2 DANS LE CAS OU ON A ENDOMMAGE LE CRITERE2 85 : C----------------------------------------------------------------- 86 : C 87 : GAMMA2=(COHE2-PHI2*SOG2(2)-SIGN(1.D0,TSOG2(4))*SOG2(4))/ 88 : 1 (PHI2*DSOG2(2)+SIGN(1.D0,TSOG2(4))*DSOG2(4)) 89 : IF(IIMPI.EQ.28) WRITE(IOIMP,3979) GAMMA2 90 : IF(GAMMA2.LE.0.D0) GAMMA2=0.D0 91 : IF(IIMPI.EQ.28) WRITE(IOIMP,3979) GAMMA2 92 : 3979 FORMAT( '0 ECUBI GAMMA2 =',1PE12.5/) 93 : C 94 : C----------------------------------------------------------- 95 : C ON REGARDE QUEL CRITERE EST ENDOMMAGE LE PREMIER 96 : C----------------------------------------------------------- 97 : C 98 : 300 GAMMA=MIN(GAMMA1,GAMMA2) 99 : C 100 : C----------------------------------------------------------- 101 : C GAMMA PLUS GRAND QUE 1 AUCUN CRITERE N'EST ENDOMMAGE 102 : C----------------------------------------------------------- 103 : C 104 : IF (GAMMA.GE.1.D0) GO TO 40000 105 : C 106 : C ------------------------------------------------------------ 107 : C GAMMA1 ET GAMMA2 PLUS PETITS QUE 1.D-5 OU GAMMA1=GAMMA2 108 : C ON EST DANS LE CAS DU COUPLAGE 109 : C ------------------------------------------------------------ 110 : C 111 : IF (GAMMA1.EQ.0.D0.AND.GAMMA2.EQ.0.D0) GO TO 30001 112 : GAM=MAX(GAMMA1,GAMMA2) 113 : IF (GAM.LT.1.D-5) GOTO 30001 114 : POURCE=ABS((GAMMA1-GAMMA2)/(GAMMA1+GAMMA2)) 115 : IF (POURCE.LE.1.D-4) GO TO 30001 116 : C 117 : C----------------------------------------------------------------- 118 : C GAMMA1 PLUS PETIT QUE GAMMA2 LE CRITERE 1 EST ENDOMMAGE PREMIER 119 : C----------------------------------------------------------------- 120 : C 121 : IF (GAMMA1.LT.GAMMA2) GO TO 10000 122 : C 123 : C----------------------------------------------------------------- 124 : C GAMMA1 PLUS PETIT QUE GAMMA2 LE CRITERE 1 EST ENDOMMAGE PREMIER 125 : C----------------------------------------------------------------- 126 : C 127 : IF (GAMMA2.LT.GAMMA1) GO TO 20000 128 : C 129 : C---------------------------------------------------- 130 : C ECOULEMENT QUAND ON A UN SEUL CRITERE 131 : C---------------------------------------------------- 132 : C 132 : 5000 CALL ECUBI1(SOG1,DSOG1,GAMMA1,PHI1,PSI1,NCAS,TRA1,XNU,YOUNG, 133 : 1 COHE1,SIGE,ESPPLA,DLAM1,CO11,SI11,HACHE1,IDAM,KERRE) 134 : GO TO 50000 135 : C 136 : C------------------------------------------------------- 137 : C ECOULEMENT SUIVANT CRITERE 1 (CAS DE 2 CRITERES) 138 : C------------------------------------------------------- 139 : C 139 : 10000 CALL ECUBI2(SOG1,DSOG1,GAMMA1,PHI1,PSI1,NCAS,TRA1, 140 : 1 XNU,YOUNG,COHE1,HACHE1,CO11,SI11, 141 : 2 PHI2,PSI2,COHE2,CO22,SI22,HACHE2,TRA2, 142 : 3 CO21,SI21,SIGE,ESPPLA,DLAM1,ICHR,SOGMA,DSOGMA,KERRE) 143 : IF(IIMPI.EQ.28) WRITE(IOIMP,3333) 144 : 3333 FORMAT( '0 ON EST PASSE PAR CRIT 1') 145 : C 146 : C--------------------------------------------- 147 : C ICHR=1 ON VA AVOIR 1 CAS DE COUPLAGE 148 : C--------------------------------------------- 149 : C 150 : IF(ICHR.EQ.0) IDAM=1 151 : IF(ICHR.EQ.0) GO TO 50000 152 : ICRI=1 153 : GO TO 30000 154 : C 155 : C-------------------------------------- 156 : C ECOULEMENT SUIVANT CRITERE 2 157 : C-------------------------------------- 158 : C 158 : 20000 CALL ECUBI2(SOG2,DSOG2,GAMMA2,PHI2,PSI2,NCAS,TRA2, 159 : 1 XNU,YOUNG,COHE2,HACHE2,CO22,SI22, 160 : 2 PHI1,PSI1,COHE1,CO11,SI11,HACHE1,TRA1, 161 : 3 CO21,-SI21,SIGE,ESPPLA,DLAM2,ICHR,SOGMA,DSOGMA,KERRE) 162 : IF(IIMPI.EQ.28) WRITE(IOIMP,4333) 163 : 4333 FORMAT( '0 ON EST PASSE PAR CRIT 2') 164 : IF(ICHR.EQ.0) IDAM=2 165 : IF(ICHR.EQ.0) GO TO 50000 166 : C 167 : C--------------------------------------------- 168 : C ICHR=1 ON VA AVOIR 1 CAS DE COUPLAGE 169 : C--------------------------------------------- 170 : C 171 : ICRI=2 172 : GO TO 30000 173 : C 174 : C---------------------------------------------- 175 : C CAS OU AUCUN CRITERE N'EST ENDOMMAGE 176 : C---------------------------------------------- 177 : C 178 : 40000 DO 55 ITYP=1,6 179 : SIGEL(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP) 180 : DLAMBD(ITYP)=0.D0 181 : 55 CONTINUE 182 : GO TO 165 183 : C 184 : C 185 : 30001 DO 23 ITYP=1,4 186 : SOGMA(ITYP)=SOGMA(ITYP)+GAMMA*DSOGMA(ITYP) 187 : DSOGMA(ITYP)=(1.D0-GAMMA)*DSOGMA(ITYP) 188 : 23 CONTINUE 189 : 30000 CONTINUE 190 : IF(IIMPI.EQ.28) WRITE(IOIMP,5333) 191 : 5333 FORMAT( '0 ON EST PASSE PAR COUPLA') 191 : CALL CHREPE (CO11,SI11,SOGMA,TSOG1) 192 : VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1) 192 : CALL CHREPE (CO22,SI22,SOGMA,TSOG2) 193 : VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2) 194 : IF(IIMPI.EQ.28) WRITE(IOIMP,1978) VCRIT1 195 : IF(IIMPI.EQ.28) WRITE(IOIMP,1979) VCRIT2 195 : CALL ECUBIC(SOGMA,DSOGMA,COHE1,COHE2,CO11,SI11, 196 : 1 CO22,SI22,CO21,SI21,TRA1,TRA2,YOUNG,XNU,DEFPL,SIGE,IDAM, 197 : 2 DLAM1,DLAM2,PSI1,PHI1,PSI2,PHI2,NCAS,ICRI,HACHE1,HACHE2,KERRE) 198 : IF(IIMPI.EQ.28) WRITE(IOIMP,1980) 199 : 1980 FORMAT( 'ON A APPELLE LE COUPLAGE') 200 : DO 174 ITYP=1,4 201 : ESPPLA(ITYP)=DEFPL(ITYP)+ESPPLA(ITYP) 202 : 174 CONTINUE 203 : GO TO 50000 204 : C 205 : C--------------------------------------------------------------- 206 : C ON REMPLIT LE TABLEAU SIGEL ET DLAMBD ET XLAMBD ET DEFPLA 207 : C--------------------------------------------------------------- 208 : C 209 : 50000 DO 21 ITYP=1,4 210 : SIGEL(ITYP)=SIGE(ITYP) 211 : DSOGMA(ITYP)=SIGMA(ITYP)+DSIGMA(ITYP)-SIGEL(ITYP) 212 : DEFPLA(ITYP)=ESPPLA(ITYP) 213 : 21 CONTINUE 214 : SIGEL(5)=DSIGMA(5)+SIGMA(5) 215 : SIGEL(6)=DSIGMA(6)+SIGMA(6) 216 : DEFPLA(5)=0.D0 217 : DEFPLA(6)=0.D0 217 : CALL CHREPE(CO11,SI11,DSOGMA,DSOG1) 217 : CALL CHREPE(CO22,SI22,DSOGMA,DSOG2) 217 : IF(NCAS.EQ.1) CALL CPCONT(DSOG1,SOG1,XNU,YOUNG) 217 : IF(NCAS.EQ.1) CALL CPCONT(DSOG2,SOG2,XNU,YOUNG) 217 : IF(NCAS.NE.1) CALL DPCONT(DSOG1,SOG1,XNU,YOUNG) 217 : IF(NCAS.NE.1) CALL DPCONT(DSOG2,SOG2,XNU,YOUNG) 218 : DLAMBD(1)=SOG1(2) 219 : DLAMBD(3)=SOG2(2) 220 : DLAMBD(2)=SOG1(4)*2.D0 221 : DLAMBD(4)=SOG2(4)*2.D0 222 : DLAMBD(5)=DLAM1 223 : DLAMBD(6)=DLAM2 224 : DO 333 ITYP=1,6 225 : XLAMBD(ITYP)=XLAMBD(ITYP)+DLAMBD(ITYP) 226 : 333 CONTINUE 226 : 165 CALL CHREPE (CO11,SI11,SIGEL,TSOG1) 227 : VCRIT1=VCRITE(TSOG1(2),TSOG1(4),PHI1,COHE1) 227 : CALL CHREPE (CO22,SI22,SIGEL,TSOG2) 228 : VCRIT2=VCRITE(TSOG2(2),TSOG2(4),PHI2,COHE2) 229 : IF(IIMPI.EQ.28) WRITE(IOIMP,1978) VCRIT1 230 : 1978 FORMAT( '0 ECUBI VCRIT1 =',1PE12.5/) 231 : IF(IIMPI.EQ.28) WRITE(IOIMP,1979) VCRIT2 232 : 1979 FORMAT( '0 ECUBI VCRIT2 =',1PE12.5/) 233 : RETURN 234 : END 235 :
© Cast3M 2003 - All rights reserved.
Disclaimer