Télécharger ecubic.eso

Retour à la liste

Numérotation des lignes :

  1. C ECUBIC SOURCE CHAT 05/01/12 23:28:10 5004
  2. SUBROUTINE ECUBIC (SOGMA,DSOGMA,COHE1,COHE2,CO11,SI11,
  3. 1 CO22,SI22,CO21,SI21,TRA1,TRA2,YOUNG,XNU,DEFPL,TSUG,IDAM,
  4. 2 DLAM1,DLAM2,PSI1,PHI1,PSI2,PHI2,NCAS,ICRI,HACHE1,HACHE2,KERRE)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7. DIMENSION DSOGMA(4),SOGMA(4),TSOG(4),TSOG1(4),TSOG2(4),
  8. 1 SIP1(4),SAP1(4),SAP(4),SIP(4),SIP2(4),SAP2(4),TSUG(4),
  9. 2 DSUG(4),SOG1(4),SOG2(4),DSOG1(4),DSOG2(4),A(3,3),B(3),
  10. 3 C(3),D(3),DEF(4),DEFPL(4),SAG1(4),SAG2(4),SEG(4)
  11. DO 100 ITYP=1,4
  12. TSOG(ITYP)=DSOGMA(ITYP)+SOGMA(ITYP)
  13. SEG(ITYP)=TSOG(ITYP)
  14. 100 CONTINUE
  15. ITER=1
  16. ICHRI=0
  17. ICHRO=0
  18. ZER=0.D0
  19. IDAM=12
  20. ISOM1=0
  21. ISOM2=0
  22. DLA1=0.D0
  23. DLA2=0.D0
  24. C------------------------------------------------------------------
  25. C ON EFFECTUE LE COUPLAGE
  26. C------------------------------------------------------------------
  27. C
  28. CALL CHREPE(CO11,SI11,TSOG,TSOG1)
  29. CALL CHREPE(CO22,SI22,TSOG,TSOG2)
  30. CALL CHREPE(CO11,SI11,SOGMA,SOG1)
  31. CALL CHREPE(CO22,SI22,SOGMA,SOG2)
  32. CALL CHREPE(CO11,SI11,DSOGMA,DSOG1)
  33. CALL CHREPE(CO22,SI22,DSOGMA,DSOG2)
  34. C---------------------------------------------------------------
  35. C SI ON EST A LA POINTE CAS PRATICULIER
  36. C IL FAUT REGARDER SI ON SORT DANS LE CONE DES NORMALES
  37. C---------------------------------------------------------------
  38. C
  39. IF(SOG1(2).GT.(1.D0-1.D-6)*TRA1) ISOM1=1
  40. IF(SOG2(2).GT.(1.D0-1.D-6)*TRA2) ISOM2=1
  41. IF((ISOM1+ISOM2).EQ.0) GO TO 90000
  42. C
  43. CIS1=SIGN(1.D0,SOG1(4))
  44. CIS2=SIGN(1.D0,SOG2(4))
  45. IF(SOG1(2).GT.(1.D0-1.D-6)*TRA1) CIS1=SIGN(1.D0,TSOG1(4))
  46. IF(SOG2(2).GT.(1.D0-1.D-6)*TRA2) CIS2=SIGN(1.D0,TSOG2(4))
  47. VCRA=DSOG1(2)-PSI1*ABS(DSOG1(4))
  48. VCRB=DSOG2(2)-PSI2*ABS(DSOG2(4))
  49. IF(ISOM1.EQ.1.AND.VCRA.GT.0.D0) ICHRO=1
  50. IF(ISOM2.EQ.1.AND.VCRB.GT.0.D0) ICHRI=1
  51. IF(ISOM1.EQ.1.AND.VCRA.GT.0.D0) GO TO 20000
  52. IF(ISOM2.EQ.1.AND.VCRB.GT.0.D0) GO TO 20000
  53. GOTO 80000
  54. C
  55. 90000 CIS1=SIGN(1.D0,SOG1(4))
  56. CIS3=SIGN(1.D0,TSOG1(4))
  57. CIS2=SIGN(1.D0,SOG2(4))
  58. CIS4=SIGN(1.D0,TSOG2(4))
  59. 80000 IF(NCAS.EQ.1) CALL CPHOOK(ZER,PSI1,ZER,CIS1,SIP1(1),SIP1(2)
  60. 1 ,SIP1(3),SIP1(4),XNU,YOUNG)
  61. ICHRO=0
  62. ICHRI=0
  63. IF(NCAS.EQ.1) CALL CPHOOK(ZER,PSI2,ZER,CIS2,SAP2(1),SAP2(2)
  64. 1 ,SAP2(3),SAP2(4),XNU,YOUNG)
  65. IF(NCAS.NE.1) CALL DPHOOK(ZER,PSI1,ZER,CIS1,SIP1(1),SIP1(2)
  66. 1 ,SIP1(3),SIP1(4),XNU,YOUNG)
  67. IF(NCAS.NE.1) CALL DPHOOK(ZER,PSI2,ZER,CIS2,SAP2(1),SAP2(2)
  68. 1 ,SAP2(3),SAP2(4),XNU,YOUNG)
  69. CALL CHREPE(CO21,SI21,SIP1,SIP2)
  70. CALL CHREPE(CO21,-SI21,SAP2,SAP1)
  71. CALL CHREPE(CO11,-SI11,SIP1,SIP)
  72. CALL CHREPE(CO22,-SI22,SAP2,SAP)
  73. ALPH1=PHI1*SIP1(2)+CIS1*SIP1(4)
  74. ALPH2=PHI1*SAP1(2)+CIS1*SAP1(4)
  75. ALPH3=-COHE1+PHI1*TSOG1(2)+CIS1*TSOG1(4)
  76. ALPH4=PHI2*SIP2(2)+CIS2*SIP2(4)
  77. ALPH5=PHI2*SAP2(2)+CIS2*SAP2(4)
  78. ALPH6=-COHE2+PHI2*TSOG2(2)+CIS2*TSOG2(4)
  79. DET=ALPH1*ALPH5-ALPH4*ALPH2
  80. REF=YOUNG*YOUNG*1.D-7
  81. IF(DET.LE.REF) GO TO 30000
  82. C------------------------------------------------------------------
  83. C SI LE DETERMINANT EST NUL ON NE PEUT EFFECTUER LE COUPLAGE
  84. C ON ECOULE DONC SUIVANT UN SEUL CRITERE (20000)
  85. C------------------------------------------------------------------
  86. C
  87. DLA1=(ALPH3*ALPH5-ALPH6*ALPH2)/DET
  88. DLA2=(ALPH1*ALPH6-ALPH3*ALPH4)/DET
  89. DO 110 ITYP=1,4
  90. DSUG(ITYP)=DLA1*SIP(ITYP)+DLA2*SAP(ITYP)
  91. TSUG(ITYP)=TSOG(ITYP)-DSUG(ITYP)
  92. DSUG(ITYP)=SEG(ITYP)-TSUG(ITYP)
  93. 110 CONTINUE
  94. CALL CHREPE(CO11,SI11,TSUG,SAG1)
  95. CALL CHREPE(CO22,SI22,TSUG,SAG2)
  96. C-----------------------------------------------------
  97. C DANS LE CAS OU ON DEPASSE LA LIMITE EN TRACTION
  98. C POUR LE CRITERE 1 OU 2 ON CALCULE DES NOUVEAUX
  99. C DLAMDA
  100. C-----------------------------------------------------
  101. IF(SAG1(2).GT.TRA1*(1.D0+1.D-6).OR.SAG2(2).GT.TRA2*(1.D0+1.D-6))
  102. 1 GO TO 500
  103. DLAM1=DLA1+DLAM1
  104. DLAM2=DLA2+DLAM2
  105. IF(NCAS.EQ.1) CALL CPCONT(DSUG,DEFPL,XNU,YOUNG)
  106. IF(NCAS.NE.1) CALL DPCONT(DSUG,DEFPL,XNU,YOUNG)
  107. RETURN
  108. 500 C(3)=100.D0
  109. D(3)=100.D0
  110. IF(SAG1(2).LE.(TRA1*(1.D0+1.D-6))) GO TO 600
  111. B(1)=-COHE1+PHI1*SOG1(2)+CIS1*SOG1(4)
  112. B(2)=-COHE2+PHI2*SOG2(2)+CIS2*SOG2(4)
  113. B(3)=SOG1(2)-TRA1
  114. A(1,3)=-(PHI1*DSOG1(2)+CIS1*DSOG1(4))
  115. A(2,3)=-(PHI2*DSOG2(2)+CIS2*DSOG2(4))
  116. A(3,3)=-DSOG1(2)
  117. A(1,1)=ALPH1
  118. A(1,2)=ALPH2
  119. A(2,1)=ALPH4
  120. A(2,2)=ALPH5
  121. A(3,1)=SIP1(2)
  122. A(3,2)=SAP1(2)
  123. CALL RESNEQ(A,B,C,3,KERRE)
  124. IF(SAG2(2).LE.(TRA2*(1.D0-1.D-6))) GO TO 800
  125. 600 B(1)=COHE1-PHI1*SOG1(2)-CIS1*SOG1(4)
  126. B(2)=COHE2-PHI2*SOG2(2)-CIS2*SOG2(4)
  127. B(3)=SOG2(2)-TRA2
  128. A(1,3)=-(PHI1*DSOG1(2)+CIS1*DSOG1(4))
  129. A(2,3)=-(PHI2*DSOG2(2)+CIS2*DSOG2(4))
  130. A(3,3)=-DSOG2(2)
  131. A(1,1)=ALPH1
  132. A(1,2)=ALPH2
  133. A(2,1)=ALPH4
  134. A(2,2)=ALPH5
  135. A(3,1)=SIP2(2)
  136. A(3,2)=SAP2(2)
  137. CALL RESNEQ(A,B,D,3,KERRE)
  138. 800 IF(D(3).LE.C(3)) DLA1=D(1)
  139. IF(D(3).GT.C(3)) ICHRO=1
  140. IF(D(3).LE.C(3)) ICHRI=1
  141. IF(ABS(D(3)-C(3)).LE.(ABS(C(3))*1.D-6)) ICHRI=1
  142. IF(ABS(D(3)-C(3)).LE.(ABS(C(3))*1.D-6)) ICHRO=1
  143. IF(D(3).LE.C(3)) DLA2=D(2)
  144. IF(D(3).LE.C(3)) XAT=D(3)
  145. IF(D(3).GT.C(3)) DLA1=C(1)
  146. IF(D(3).GT.C(3)) DLA2=C(2)
  147. IF(D(3).GT.C(3)) XAT=C(3)
  148. DO 111 ITYP=1,4
  149. DSUG(ITYP)=DLA1*SIP(ITYP)+DLA2*SAP(ITYP)
  150. SOGMA(ITYP)=SOGMA(ITYP)-DSUG(ITYP)+XAT*DSOGMA(ITYP)
  151. DSOGMA(ITYP)=(1.D0-XAT)*DSOGMA(ITYP)
  152. TSOG(ITYP)=DSOGMA(ITYP)+SOGMA(ITYP)
  153. 111 CONTINUE
  154. DLAM1=DLAM1+DLA1
  155. DLAM2=DLAM2+DLA2
  156. CALL CHREPE(CO11,SI11,TSOG,TSOG1)
  157. CALL CHREPE(CO22,SI22,TSOG,TSOG2)
  158. CALL CHREPE(CO11,SI11,SOGMA,SOG1)
  159. VCRIT1=VCRITE(SOG1(2),SOG1(4),PHI1,COHE1)
  160. CALL CHREPE(CO22,SI22,SOGMA,SOG2)
  161. VCRIT2=VCRITE(SOG2(2),SOG2(4),PHI2,COHE2)
  162. CALL CHREPE(CO22,SI22,DSOGMA,DSOG2)
  163. CALL CHREPE(CO11,SI11,DSOGMA,DSOG1)
  164. VCRA=DSOG1(2)-PSI1*ABS(DSOG1(4))
  165. VCRB=DSOG2(2)-PSI2*ABS(DSOG2(4))
  166. ITER=ITER+1
  167. IF(ICHRO.EQ.1.AND.VCRA.GT.0.D0) GO TO 20000
  168. IF(ICHRI.EQ.1.AND.VCRB.GT.0.D0) GO TO 20000
  169. IF(ITER.EQ.7) GO TO 20000
  170. C
  171. IF(ICHRO.EQ.1) CIS1=SIGN(1.D0,TSOG1(4))
  172. IF(ICHRO.NE.1) CIS1=SIGN(1.D0,SOG1(4))
  173. IF(ICHRI.EQ.1) CIS2=SIGN(1.D0,TSOG2(4))
  174. IF(ICHRI.NE.1) CIS2=SIGN(1.D0,SOG2(4))
  175. GO TO 80000
  176. C
  177. C---------------------------------------------------------
  178. C CAS OU LES DEUX CRITERES SONT CONFONDUS
  179. C---------------------------------------------------------
  180. C
  181. 30000 IF(ICRI.EQ.1) CALL CHREPE(CO11,SI11,SOGMA,SOG1)
  182. IF(ICRI.EQ.1) CALL CHREPE(CO11,SI11,DSOGMA,DSOG1)
  183. IF(ICRI.EQ.2) CALL CHREPE(CO22,SI22,DSOGMA,DSOG2)
  184. IF(ICRI.EQ.2) CALL CHREPE(CO22,SI22,SOGMA,SOG2)
  185. GAMMA1=0.D0
  186. GAMMA2=0.D0
  187. IF(ICRI.EQ.1) CALL ECUBI1(SOG1,DSOG1,GAMMA1,PHI1,PHI1,NCAS,TRA1,
  188. 1 XNU,YOUNG,COHE1,TSUG,DEFPL,DLA1,CO11,SI11,HACHE1,IDAM,KERRE)
  189. IF(ICRI.EQ.1) DLAM1=DLA1+DLAM1
  190. IF(ICRI.EQ.2) CALL ECUBI1(SOG2,DSOG2,GAMMA2,PHI2,PHI2,NCAS,TRA2,
  191. 1 XNU,YOUNG,COHE2,TSUG,DEFPL,DLA2,CO22,SI22,HACHE2,IDAM,KERRE)
  192. IF(ICRI.EQ.2) DLAM2=DLA2+DLAM2
  193. DO 126 ITYP=1,4
  194. DSUG(ITYP)=SEG(ITYP)-TSUG(ITYP)
  195. 126 CONTINUE
  196. IF(NCAS.EQ.1) CALL CPCONT(DSUG,DEFPL,XNU,YOUNG)
  197. IF(NCAS.NE.1) CALL DPCONT(DSUG,DEFPL,XNU,YOUNG)
  198. RETURN
  199. C
  200. C
  201. C---------------------------------------------
  202. C CAS OU RAMENERAIT MAL A LA POINTE
  203. C SIGMA0 EN DEHORS DU CRITERE AVANT
  204. C DE RAMENER AU SOMMET
  205. C---------------------------------------------
  206. C20000 IF(ICHRI.EQ.2) GOTO 621
  207. C COEF1=PHI2*SI21*SI21-CIS2*SI21*CO21
  208. C IF(ABS(COEF1).LE.1.D-6) GOTO 622
  209. C COEF2=COHE2-(PHI2*CO21*CO21-CIS2*SI21*CO21)*TRA1
  210. C SOG1(1)=COEF2/COEF1
  211. C SOG1(2)=TRA1
  212. C SOG1(4)=0.D0
  213. C CALL CHREPE(CO11,-SI11,SOG1,SOGMA)
  214. C DO 623 ITYP=1,4
  215. C DSOGMA(ITYP)=SEG(ITYP)-SOGMA(ITYP)
  216. C 623 CONTINUE
  217. C GOTO 622
  218. C 621 COEF1=PHI1*SI21*SI21+CIS1*SI21*CO21
  219. C IF(ABS(COEF1).LE.1.D-6) GOTO 622
  220. C COEF2=COHE1-(PHI1*CO21*CO21+CIS1*SI21*CO21)*TRA2
  221. C SOG2(1)=COEF2/COEF1
  222. C SOG2(2)=TRA2
  223. C SOG2(4)=0.D0
  224. C CALL CHREPE(CO22,-SI22,SOG2,SOGMA)
  225. C DO 624 ITYP=1,4
  226. C DSOGMA(ITYP)=SEG(ITYP)-SOGMA(ITYP)
  227. C 624 CONTINUE
  228. C IF(NCAS.NE.1) CALL DPCONT(DSOGMA,DEF,XNU,YOUNG)
  229. C DLA=SQRT(DEF(1)*DEF(1)+DEF(2)*DEF(2)+DEF(3)*DEF(3)
  230. C 1 +DEF(4)*DEF(4))
  231. C DLAM1=DLA/2.D0+DLAM1
  232. C DLAM2=DLA/2.D0+DLAM2
  233. C DO 125 ITYP=1,4
  234. C DSUG(ITYP)=SEG(ITYP)-SOGMA(ITYP)
  235. C TSUG(ITYP)=SOGMA(ITYP)
  236. C 125 CONTINUE
  237. C IF(NCAS.NE.1) CALL DPCONT(DSUG,DEFPL,XNU,YOUNG)
  238. C RETURN
  239. C END
  240. C
  241. C-------------------------------------------------------------
  242. C CAS OU ON EST A LA LIMITE EN TRACTION D'UN CRITERE
  243. C ET A LA SURFACE DE L'AUTRE (ON RAMENE A LA POINTE)
  244. C-------------------------------------------------------------
  245. 20000 IF(NCAS.EQ.1) CALL CPCONT(DSOGMA,DEF,XNU,YOUNG)
  246. IF(NCAS.NE.1) CALL DPCONT(DSOGMA,DEF,XNU,YOUNG)
  247. DLA=SQRT(DEF(1)*DEF(1)+DEF(2)*DEF(2)+DEF(3)*DEF(3)
  248. 1 +DEF(4)*DEF(4))
  249. DLAM1=DLA/2.D0+DLAM1
  250. DLAM2=DLA/2.D0+DLAM2
  251. DO 125 ITYP=1,4
  252. DSUG(ITYP)=SEG(ITYP)-SOGMA(ITYP)
  253. TSUG(ITYP)=SOGMA(ITYP)
  254. 125 CONTINUE
  255. IF(NCAS.EQ.1) CALL CPCONT(DSUG,DEFPL,XNU,YOUNG)
  256. IF(NCAS.NE.1) CALL DPCONT(DSUG,DEFPL,XNU,YOUNG)
  257. RETURN
  258. END
  259.  
  260.  

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