Télécharger ottoin.eso

Retour à la liste

Numérotation des lignes :

  1. C OTTOIN SOURCE AM 15/12/16 21:15:17 8753
  2. SUBROUTINE OTTOIN(ISING,IFERM,IBRUP,LEBIL,PENTE,PENTE2,
  3. & NCA,NN,MC,MM,SIGEL,DSIGT,DDE,GS,FC,
  4. & XINVL,SMAX,XLTR,PRECIZ,XCOMP,
  5. & XLAMC,KERRE)
  6. C----------------------------------------------------------------------
  7. C
  8. C ENTREES : SIG0,DEPST,PRECIZ,MFR,KERRE
  9. C
  10. C SORTIES : SIGF
  11. C
  12. C-----------------------------------------------------------------------
  13. C
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8(A-H,O-Z)
  16. -INC CCOPTIO
  17. *
  18. PARAMETER (XZER=0.D0,NC=4)
  19.  
  20. DIMENSION SIGEL(*),DSIGT(*),DDE(*),XLTR(*),XCOMP(*)
  21. DIMENSION SMAX(*),ISING(*),IFERM(*),IBRUP(*)
  22. DIMENSION FC(*),NN(*),PENTE(*),LEBIL(*),PENTE2(*)
  23. DIMENSION MM(*)
  24. DIMENSION DSIG(6) ,DSIGP(6)
  25. DIMENSION SAUX(6),DDPLAS(6)
  26. *
  27. DIMENSION GS(3)
  28. DIMENSION XINVL(3),NSITUA(4)
  29. *
  30. DIMENSION DFF(6),DGG(6)
  31. *
  32. DIMENSION JESEC(4)
  33. *
  34. DIMENSION LEBIL2(6),PENT(6),NN2(NC)
  35. DIMENSION AA(NC+1,NC+1),BB1(NC+1),BB2(NC+1)
  36. DIMENSION DX(NC+1),DDX(NC+1)
  37. DIMENSION VEC1(NC+1),VEC2(NC+1)
  38. DIMENSION DFDS(6,NC),DGDS(6,NC),HDFDQ(NC)
  39. DIMENSION LASIT(NC)
  40. DIMENSION VAUX1(6)
  41. *
  42. IF(IIMPI.EQ.42) THEN
  43. WRITE(IOIMP,74011) (ISING(IC),IC=1,NC)
  44. WRITE(IOIMP,74111) (IFERM(IC),IC=1,NC)
  45. WRITE(IOIMP,74211) (IBRUP(IC),IC=1,NC)
  46. WRITE(IOIMP,74311) (NN(IC),IC=1,NCA)
  47. 74011 FORMAT(5X,' ENTREE DANS OTTOIN - ISING = ',4I3/)
  48. 74111 FORMAT(5X,' ENTREE DANS OTTOIN - IFERM = ',4I3/)
  49. 74211 FORMAT(5X,' ENTREE DANS OTTOIN - IBRUP = ',4I3/)
  50. 74311 FORMAT(//5X,' ENTREE DANS OTTOIN - NN = ',4I3/)
  51. ENDIF
  52. *
  53. IF(IFERM(4).EQ.1.AND.ABS(FC(4)).GT.PRECIZ) THEN
  54. PRINT *,'OTTOIN - INCOHERENCE EN COMPRESSION '
  55. KERRE=2
  56. RETURN
  57. ENDIF
  58. *
  59. * INITIALISATIONS
  60. *
  61. NC1=NC+1
  62. KERRE=0
  63. CALL SHIFTD(PENTE,PENT,6)
  64. PRECIE=1.D-10
  65. *
  66. *
  67. DO IC=1,4
  68. NSITUA(IC)=1 + ISING(IC) + IFERM(IC) + IBRUP(IC)
  69.  
  70. IF(IIMPI.EQ.42) THEN
  71. WRITE(IOIMP,69980) IC,NSITUA(IC)
  72. 69980 FORMAT(//2X,' IC= ',I4,2X,' NSITUA= ',I4//)
  73. ENDIF
  74.  
  75.  
  76. *
  77. IF(NSITUA(IC).GT.2) THEN
  78. WRITE(IOIMP,74412) IC,ISING(IC),IFERM(IC),IBRUP(IC)
  79. 74412 FORMAT(2X,'####### CAS IMPOSSIBLE IC=',I3,2X,
  80. & 'ISING(IC)=',I3,2X,'IFERM(IC)=',I3,2X,
  81. & 'IBRUP(IC)=',I3/)
  82. KERRE=7
  83. RETURN
  84. ENDIF
  85. ENDDO
  86.  
  87. *
  88. DO 21 I1=1,NSITUA(1)
  89. LASIT(1)=I1
  90. *
  91. DO 22 I2=1,NSITUA(2)
  92. LASIT(2)=I2
  93. *
  94. DO 23 I3=1,NSITUA(3)
  95. LASIT(3)=I3
  96. *
  97. DO 24 I4=1,NSITUA(4)
  98. LASIT(4)=I4
  99. *
  100. * TYPES 1 (ISING) ( IC=1 A 3 )
  101. * 1 : PENTE2 (SECANTE)
  102. * 2 : PENTE
  103. *
  104. * TYPES 2 (IFERM) ( IC=1 A 4 )
  105. * 1 : ELASTIQUE
  106. * 2 : PENTE SECANTE
  107. *
  108. * TYPES 3 (IBRUP) ( IC=1 A 3 )
  109. * 1 : ELASTIQUE
  110. * 2 : PENTE
  111. *
  112. DO IC=1,3
  113. IF(LASIT(IC).EQ.2) THEN
  114. PENT(IC)=PENTE(IC)
  115. ELSE IF(LASIT(IC).EQ.1.AND.ISING(IC).EQ.1) THEN
  116. PENT(IC)=PENTE2(IC)
  117. ENDIF
  118. ENDDO
  119.  
  120. IF(IIMPI.EQ.42) THEN
  121. WRITE(IOIMP,60080) I1,I2,I3,I4
  122. 60080 FORMAT(//2X,' ******** SITUATION : I1 I2 I3 I4 ',
  123. & 4I3///)
  124. ENDIF
  125.  
  126.  
  127. IF(IIMPI.EQ.42) THEN
  128. WRITE(IOIMP,10080) (PENTE(IC),IC=1,3)
  129. 10080 FORMAT(/2X,' PENTE ',3(2X,1PE12.5)/)
  130. WRITE(IOIMP,10081) (PENTE2(IC),IC=1,3)
  131. 10081 FORMAT(/2X,' PENTE2 ',3(2X,1PE12.5)/)
  132. WRITE(IOIMP,10082) (PENT(IC),IC=1,3)
  133. 10082 FORMAT(/2X,' PENT ',3(2X,1PE12.5)/)
  134. ENDIF
  135.  
  136. *
  137. *
  138. CALL IANUL(JESEC,4)
  139. NCA2=0
  140. DO IJ=1,NCA
  141. JJ=NN(IJ)
  142.  
  143. IF(IIMPI.EQ.42) THEN
  144. WRITE(IOIMP,20080) JJ,LASIT(JJ),IFERM(JJ),IBRUP(JJ)
  145. 20080 FORMAT(/2X,'JJ=',I3,2X, 'LASIT=',I3,2X,
  146. & 'IFERM=',I3,2X,'IBRUP=',I3//)
  147. ENDIF
  148.  
  149.  
  150.  
  151. IF(LASIT(JJ).EQ.1) THEN
  152. IF(IFERM(JJ).NE.1.AND.IBRUP(JJ).NE.1) THEN
  153. NCA2=NCA2+1
  154. NN2(NCA2)=JJ
  155. ENDIF
  156. *
  157. ELSE IF(LASIT(JJ).EQ.2) THEN
  158. NCA2=NCA2+1
  159. NN2(NCA2)=JJ
  160. IF(IFERM(JJ).EQ.1.AND.JJ.LE.3) THEN
  161. JESEC(JJ)=1
  162. ENDIF
  163. ENDIF
  164. *
  165. ENDDO
  166.  
  167. IF(IIMPI.EQ.42) THEN
  168. WRITE(IOIMP,60086) NCA,NCA2
  169. 60086 FORMAT(//
  170. & 2X,'NCA=',I3,2X,'NCA2=',I3/)
  171. ENDIF
  172. *
  173. *
  174. IF(NCA2.EQ.0) THEN
  175. GO TO 55
  176. ENDIF
  177. *
  178. * INITIALISATIONS
  179. *
  180. CALL ZDANUL(VAUX1,6)
  181. CALL ZDANUL(DDPLAS,6)
  182.  
  183.  
  184. IF(IIMPI.EQ.42) THEN
  185. WRITE(IOIMP,60081) (SIGEL(I),I=1,6)
  186. 60081 FORMAT(2X,' SIGEL '/(6(1X,1PE12.5))/)
  187. ENDIF
  188. *
  189. *
  190. CALL OTTOFL(NCA2,NN2,XINVL,PENT,SIGEL,GS,SMAX,XLTR,
  191. & DFDS,DGDS,HDFDQ,XCOMP,XLAMC,PRECIE,
  192. & PRECIZ,KERRE)
  193. IF(KERRE.NE.0) RETURN
  194. *
  195. *
  196. NDIM=NCA2
  197. IF(IFOUR.EQ.-2) NDIM=NCA2+1
  198. *
  199. IF(IIMPI.EQ.42) THEN
  200. WRITE(IOIMP,77010) NCA2,NDIM
  201. 77010 FORMAT(5X,'NCA2=',I3,2X,'NDIM =',I3/)
  202. WRITE(IOIMP,77018) (NN2(IJ),IJ=1,NCA2)
  203. 77018 FORMAT(5X,'NN2 ',5(1X,I3))
  204. ENDIF
  205. *
  206. DO IJ=1,NCA2
  207. *
  208. JJ=NN2(IJ)
  209. CALL OTTOPR(DDE,DGDS(1,JJ),VAUX1)
  210. *
  211. DO IK=1,NCA2
  212. JK=NN2(IK)
  213. AA(IK,IJ)= SDOT(6,DFDS(1,JK),1,VAUX1,1)
  214. IF(IK.EQ.IJ) AA(IK,IJ)=AA(IK,IJ)-HDFDQ(JK)
  215. ENDDO
  216. BB1(IJ)=FC(JJ)
  217. BB2(IJ)=SDOT(6,DFDS(1,JJ),1,DSIGT,1)
  218.  
  219. *
  220. * SPECIAL CP
  221. *
  222. IF(IFOUR.EQ.-2) THEN
  223. AA(IJ,NDIM)=-(DFDS(1,JJ)*DDE(1)+DFDS(2,JJ)*DDE(6)
  224. * +DFDS(3,JJ)*DDE(5)+DFDS(4,JJ)*DDE(10))
  225. AA(NDIM,IJ)=VAUX1(1)
  226. ENDIF
  227. ENDDO
  228. *
  229. IF(IFOUR.EQ.-2) THEN
  230. AA(NDIM,NDIM)=-DDE(1)
  231. BB1(NDIM)=SIGEL(1)
  232. BB2(NDIM)=DSIGT(1)
  233. ENDIF
  234. *
  235. * IF(IIMPI.EQ.42) THEN
  236. * WRITE(IOIMP,77011) ((AA(I,J),J=1,5),I=1,5)
  237. *77011 FORMAT(5X,' MATRICE AA'/(5(1X,1PE12.5)))
  238. * WRITE(IOIMP,77012) (BB1(I),I=1,5)
  239. *77012 FORMAT(5X,' VECTEUR BB1'/(5(1X,1PE12.5)))
  240. * WRITE(IOIMP,70012) (BB2(I),I=1,5)
  241. *70012 FORMAT(5X,' VECTEUR BB2'/(5(1X,1PE12.5)))
  242. * ENDIF
  243. *
  244. *
  245. KERRE=0
  246. CALL INVALM(AA,NC1,NDIM,KERRE,PRECIZ)
  247. IF(KERRE.NE.0) THEN
  248. PRINT *,' MATRICE SINGULIERE DANS OTTOIN '
  249. RETURN
  250. ENDIF
  251. * IF(IIMPI.EQ.42) THEN
  252. * WRITE(IOIMP,77113) ((AA(I,J),J=1,5),I=1,5)
  253. *77113 FORMAT(5X,' MATRICE AA INVERSEE '/(5(1X,1PE12.5)))
  254. * ENDIF
  255. *
  256. CALL MULMA2(VEC1,AA,BB1,NDIM,1,NDIM,NC1,NC1)
  257. CALL MULMA2(VEC2,AA,BB2,NDIM,1,NDIM,NC1,NC1)
  258. *
  259. DO IJ=1,NDIM
  260. DDX(IJ)=VEC1(IJ)+VEC2(IJ)
  261. ENDDO
  262.  
  263. IF(IIMPI.EQ.42) THEN
  264. WRITE(IOIMP,77013) (DDX(IJ),IJ=1,NDIM)
  265. 77013 FORMAT(5X,' OTTOIN - DDX CALCULE'/(5(1X,1PE12.5)))
  266. ENDIF
  267. *
  268. *
  269. DO IJ=1,NCA2
  270. JJ=NN2(IJ)
  271. DO I=1,6
  272. DDPLAS(I)=DDPLAS(I)+DGDS(I,JJ)*DDX(IJ)
  273. ENDDO
  274. ENDDO
  275. *
  276. CALL OTTOPR(DDE,DDPLAS,DSIGP)
  277. *
  278. IF(IFOUR.EQ.-2) THEN
  279. DSIGP(1)=DSIGP(1)-DDE(1)*DDX(NDIM)
  280. DSIGP(2)=DSIGP(2)-DDE(6)*DDX(NDIM)
  281. DSIGP(3)=DSIGP(3)-DDE(5)*DDX(NDIM)
  282. DSIGP(4)=DSIGP(4)-DDE(10)*DDX(NDIM)
  283. ENDIF
  284. *
  285. DO I=1,6
  286. DSIG(I)=DSIGT(I)-DSIGP(I)
  287. ENDDO
  288. IF(IIMPI.EQ.42) THEN
  289. WRITE(IOIMP,79013) (DSIG(I),I=1,6)
  290. 79013 FORMAT(5X,' DSIG CALCULE '/(6(1X,1PE12.5)))
  291. ENDIF
  292. *
  293. *
  294. IFLAG=0
  295. DO IJ=1,NCA2
  296. JJ=NN2(IJ)
  297. IF(ISING(JJ).EQ.1) THEN
  298. IF(DSIG(JJ).GT.PRECIZ) IFLAG=1
  299. IF(PENT(JJ).EQ.PENTE(JJ).AND.DDX(IJ).LT.0.D0) IFLAG=1
  300. IF(PENT(JJ).EQ.PENTE2(JJ).AND.DDX(IJ).GT.0.D0) IFLAG=1
  301. ENDIF
  302. *
  303. IF(IFERM(JJ).EQ.1) THEN
  304. IF(DDX(IJ).LT.0.D0) IFLAG=1
  305. * AM 11/12/15 ON AJOUTE LE TEST (JJ.NE.4) CI DESSOUS
  306. IF(JJ.NE.4.AND.DSIG(JJ).LT.-PRECIZ) IFLAG=1
  307. ENDIF
  308. ENDDO
  309. *
  310. DO I=1,3
  311. IF(IFERM(I).EQ.1.AND.LASIT(I).EQ.1) THEN
  312. IF(DSIG(I).GT.PRECIZ) IFLAG=1
  313. ENDIF
  314. ENDDO
  315. *
  316. DO I=1,3
  317. IF(IBRUP(I).EQ.1.AND.LASIT(I).EQ.1) THEN
  318. IF(DSIG(I).GT.PRECIZ) IFLAG=1
  319. ENDIF
  320. ENDDO
  321.  
  322. *
  323. * MLR 9/7/99
  324. *
  325. DO IJ=1,NCA
  326. JJ=NN(IJ)
  327. IF(JJ.EQ.4.AND.LASIT(4).EQ.1) THEN
  328. CALL OTTOCP(SIGEL,FCR4,XLTR,DFF,DGG,H4,
  329. & PRECIE,PRECIZ,XCOMP,XLAMC,KERRE)
  330. *
  331. TRA = 0.D0
  332. DO I=1,6
  333. TRA = TRA + DFF(I)*DSIG(I)
  334. ENDDO
  335. IF(IIMPI.EQ.42) THEN
  336. WRITE(IOIMP,76621) TRA
  337. 76621 FORMAT(///2X,'OTTOIN ****** TRA = ',1PE12.5//)
  338. ENDIF
  339. IF(TRA.GT.PRECIZ) IFLAG=1
  340. ENDIF
  341. ENDDO
  342. *
  343. *
  344. IF(IFLAG.EQ.0) THEN
  345. DO IJ=1,NCA2
  346. JJ=NN2(IJ)
  347. IF(ISING(JJ).EQ.1) THEN
  348. IF(PENT(JJ).EQ.PENTE(JJ)) THEN
  349. ISING(JJ)=2
  350. LEBIL(JJ)=0
  351. ENDIF
  352. IF(PENT(JJ).EQ.PENTE2(JJ)) THEN
  353. ISING(JJ)=3
  354. LEBIL(JJ)=1
  355. ENDIF
  356. ENDIF
  357. ENDDO
  358. GO TO 99
  359. ENDIF
  360.  
  361. *
  362. 55 CONTINUE
  363. *
  364. 24 CONTINUE
  365. *
  366. 23 CONTINUE
  367. *
  368. 22 CONTINUE
  369. *
  370. 21 CONTINUE
  371.  
  372.  
  373. *
  374. * EN CAS DE PROBLEME :
  375. *
  376. KERRE=7
  377. * VALEUR DE KERRE A AMELIORER
  378. *
  379. WRITE(IOIMP,73312)
  380. 73312 FORMAT(2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ' /
  381. & 4X,'ATTENTION - OTTOIN - PAS DE SOLUTION ' /
  382. & 2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ'/)
  383. RETURN
  384.  
  385.  
  386. *
  387. 99 CONTINUE
  388. *
  389. CALL SHIFTD(PENT,PENTE,6)
  390.  
  391. IF(IIMPI.EQ.42) THEN
  392. WRITE(IOIMP,70801) (PENTE(I),I=1,NC)
  393. 70801 FORMAT(///2X,'OTTOIN SORTIE - PENTE '/(4(1X,1PE12.5)/))
  394. WRITE(IOIMP,76802) (LEBIL(I),I=1,NC)
  395. 76802 FORMAT(/2X,'OTTOIN SORTIE - LEBIL '/(4I5/))
  396. WRITE(IOIMP,76803) (ISING(I),I=1,NC)
  397. 76803 FORMAT(/2X,'OTTOIN SORTIE - ISING '/(4I5/))
  398. ENDIF
  399. *
  400. * RETRAITEMENT
  401. *
  402. NCA=NCA2
  403. DO I=1,NCA
  404. NN(I)=NN2(I)
  405. ENDDO
  406. *
  407. MC2=0
  408. DO I=1,MC
  409. *
  410. * TYPES 1
  411. *
  412. IF(MM(I).GE.7.AND.MM(I).LE.9) THEN
  413. IC=MM(I)-6
  414. IF(ISING(IC).EQ.3) GO TO 101
  415. ENDIF
  416.  
  417. IF(MM(I).GE.13.AND.MM(I).LE.15) THEN
  418. IC=MM(I)-12
  419. IF(ISING(IC).EQ.2) GO TO 101
  420. ENDIF
  421. *
  422. * TYPES 2
  423. *
  424. IF(MM(I).GE.4.AND.MM(I).LE.6) THEN
  425. IC=MM(I)-3
  426. IF(IFERM(IC).EQ.1.AND.JESEC(IC).EQ.0) GO TO 101
  427. ENDIF
  428. *
  429. MC2=MC2+1
  430. MM(MC2)=MM(I)
  431. 101 CONTINUE
  432. ENDDO
  433. MC=MC2
  434.  
  435. IF(IIMPI.EQ.42) THEN
  436. WRITE(IOIMP,44102) NCA
  437. 44102 FORMAT(2X,'OTTOIN - NOUVELLE VALEUR NCA =',I3/)
  438. WRITE(IOIMP,44103) (NN(IC),IC=1,NCA)
  439. 44103 FORMAT(2X,'OTTOIN - NOUVELLE LISTE NN '/16(1X,I3)/)
  440. WRITE(IOIMP,49102) MC
  441. 49102 FORMAT(2X,'OTTOIN - NOUVELLE VALEUR MC =',I3/)
  442. WRITE(IOIMP,49103) (MM(IC),IC=1,MC)
  443. 49103 FORMAT(2X,'OTTOIN - NOUVELLE LISTE MM '/16(1X,I3)/)
  444. ENDIF
  445.  
  446.  
  447. RETURN
  448. END
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  

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