Télécharger ecubi.eso

Retour à la liste

Numérotation des lignes :

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

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