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

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