Télécharger critp.eso

Retour à la liste

Numérotation des lignes :

  1. C CRITP SOURCE AM 16/04/12 21:15:19 8903
  2. SUBROUTINE CRITP(IPMODL,IPCHE1,IPCHE2,IPCAR,IPCHE3)
  3. *******************************************************************
  4. *
  5. * CALCUL LE CRITERE DE PLASTICITE
  6. *
  7. **********************************************************************
  8. *
  9. * ENTREES:
  10. *
  11. * IPMODL = POINTEUR SUR UN OBJET MMODEL
  12. * IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES
  13. * IPCHE2 = POINTEUR SUR UN MCHAML DE VARIABLES INTERNES
  14. * IPCAR = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  15. *
  16. * SORTIES:
  17. *
  18. * IPCHE3 = POINTEUR SUR UN MCHAML SCALAIRE
  19. *
  20. ************************************************************************
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8(A-H,O-Z)
  23. *
  24. -INC CCOPTIO
  25. -INC SMCHAML
  26. -INC SMELEME
  27. -INC SMCOORD
  28. -INC SMMODEL
  29. -INC SMINTE
  30. -INC CCHAMP
  31. C----------------------------------------------------------------------
  32. C KERRE REGIT LES MESSAGES D'ERREUR DANS CRIT
  33. C
  34. C = 0 TOUT OK
  35. C = 1 ET 2 S ALIGNER SUR LES VALEURS DONNEES PAR ECOCRI
  36. C = 7 UN ELEMENT TUYAU A UNE EPAISSEUR NULLE
  37. C
  38. C ANOMALIES AVEC LA COURBE DE TRACTION
  39. C = 30 LIMITE ELASTIQUE NULLE
  40. C = 31 TROP DE POINTS
  41. C = 32 PAS ASSEZ DE POINTS
  42. C = 33 PENTE INCORRECTE
  43. C = 34 MODULE D'YOUNG NUL
  44. C = 35 MANQUE L'ORIGINE
  45. C = 36 PENTE A L'ORIGINE NON EGALE A E
  46. C = 37 MANQUE LA COURBE DE TRACTION
  47. C = 48 DONNEES DRUCKER-PRAGER ERRONNEES
  48. C = 99 CAS NON ENCORE DISPONIBLE
  49. C----------------------------------------------------------------------
  50. C
  51. SEGMENT NOTYPE
  52. CHARACTER*16 TYPE(NBTYPE)
  53. ENDSEGMENT
  54. *
  55. SEGMENT MPTVAL
  56. INTEGER IPOS(NS) ,NSOF(NS)
  57. INTEGER IVAL(NCOSOU)
  58. CHARACTER*16 TYVAL(NCOSOU)
  59. ENDSEGMENT
  60. *
  61. SEGMENT WRK0
  62. REAL*8 XMAT(NCXMAT)
  63. ENDSEGMENT
  64. *
  65. SEGMENT WRK1
  66. REAL*8 DDHOOK(NSTRS,NSTRS),SIG0(NSTRS),DSIGT(NSTRS)
  67. REAL*8 SIGF(NSTRS),VAR0(NVARI),VARF(NVARI)
  68. REAL*8 DEFP(NSTRS),XCAR(ICARA)
  69. ENDSEGMENT
  70. *
  71. SEGMENT WRK2
  72. REAL*8 TRAC(LTRAC)
  73. ENDSEGMENT
  74. *
  75. SEGMENT WRK3
  76. REAL*8 WORK(LW),WORK2(LW2)
  77. ENDSEGMENT
  78. *
  79. SEGMENT WRK4
  80. REAL*8 XE(3,NBBB)
  81. ENDSEGMENT
  82. *
  83. SEGMENT ECOU
  84. *** COMMON/ECOU/TEST,ALFAH,
  85. REAL*8 TEST,ALFAH,
  86. C REAL*8 TEST, ALFAH,
  87. 1 HPAS, TEMPS,ecow3(6),ecow4(9),ecow5(6),
  88. C 1 HPAS,TEMPS,COVNMS(6),VECPRO(9),VALPRO(6),
  89. 2 ecow6(12),ecow7(6),ecow8(6),ecow9(6),ecow10(6),ecow11(6),
  90. 2 ecow12(6),
  91. C 2 CVNMSD(12),STOT(6),SIGEL(6),DSIGP(6),SIGT(6),W1(6),W2(6),
  92. 1 ecow13(6),ecow14(6),ecow15(12),ecow16(3),
  93. C 1 DALPHA(6),EPSPLA(6),E(12),XINV(3),
  94. 2 ecow17(6),ecow18(6),ecow19,ecow20
  95. C 2 SIPLAD(6),DSIGP0(6),TET,TETI
  96. ENDSEGMENT
  97.  
  98. SEGMENT NECOU
  99. * COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  100. INTEGER NCOURB, IPLAST,IT,IMAPLA, ISOTRO,
  101. C INTEGER NCOURB,IPLAST,IT, IMAPLA,ISOTRO,
  102. 1 ITYP, IFOURB, IFLUAG,
  103. C . ITYP, IFOURB,IFLUAG,
  104. 2 ICINE,ITHER, IFLUPL,ICYCL, IBI,
  105. C . ICINE,ITHER, IFLUPL,ICYCL, IBI,
  106. 3 JFLUAG,KFLUAG, LFLUAG,
  107. C . JFLUAG,KFLUAG,LFLUAG,
  108. 4 IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEP
  109. C . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF
  110. ENDSEGMENT
  111. * COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  112. * . ITYP,IFOURB,IFLUAG,
  113. * . ICINE,ITHER,IFLUPL,ICYCL,IBI,
  114. * . JFLUAG,KFLUAG,LFLUAG,
  115. * . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF
  116.  
  117. DIMENSION MOMAT(2)
  118. DIMENSION XEPOU(2),YEPOU(2),ZEPOU(2)
  119. DIMENSION BID(3)
  120. *
  121. CHARACTER*8 CMATE
  122. CHARACTER*(NCONCH) CONM
  123. PARAMETER ( NINF=3 )
  124. INTEGER INFOS(NINF)
  125. LOGICAL LSUPVA,lsupco,lsupma
  126. DATA IUN,IZERO/1,0/
  127. DATA UN,XZER,UNDEMI/1.D0,0.D0,.5D0/
  128. C
  129. NHRM=NIFOUR
  130. C
  131. C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES
  132. C
  133. CALL QUESUP(IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  134. IF (ISUP1.GT.1) RETURN
  135. C
  136. C VERIFICATION DU LIEU SUPPORT DU MCHAML DE VARIABLES INTERNES
  137. C
  138. CALL QUESUP(IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  139. IF (ISUP2.GT.1) RETURN
  140. C
  141. C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  142. C
  143. CALL QUESUP(IPMODL,IPCAR,5,0,ISUP3,IRET3)
  144. IF (ISUP3.GT.1) RETURN
  145. C
  146. C ACTIVATION DU MODELE
  147. C
  148. MMODEL=IPMODL
  149. SEGACT MMODEL
  150. NSOUS=KMODEL(/1)
  151. C
  152. C CREATION DU MCHAML
  153. C
  154. N1=NSOUS
  155. L1=8
  156. N3=6
  157. SEGINI MCHELM
  158. TITCHE='SCALAIRE'
  159. IFOCHE=IFOUR
  160. IPCHE3=MCHELM
  161. C____________________________________________________________________
  162. C
  163. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  164. C____________________________________________________________________
  165. C
  166. DO 500 ISOUS=1,NSOUS
  167. *
  168. * INITIALISATION
  169. *
  170. segini necou,ecou
  171. NSTR=0
  172. MOSTRS=0
  173. IVASTR=0
  174. MOVARI=0
  175. NVARI=0
  176. IVARI=0
  177. NCARA=0
  178. NCARF=0
  179. MOCARA=0
  180. IVACAR=0
  181. NMATF=0
  182. NMATR=0
  183. MOMATR=0
  184. IVAMAT=0
  185. IMELCR=0
  186. KERRE=0
  187. KERR1=0
  188. lsupma=.true.
  189. lsupva=.false.
  190. C
  191. C ON RECUPERE L INFORMATION GENERALE
  192. C
  193. IMODEL=KMODEL(ISOUS)
  194. SEGACT IMODEL
  195. IPMAIL=IMAMOD
  196. CONM =CONMOD
  197. IMACHE(ISOUS)=IPMAIL
  198. CONCHE(ISOUS)=CONMOD
  199. *
  200. MELE=NEFMOD
  201. MELEME=IMAMOD
  202. SEGACT MELEME
  203. NBNN=NUM(/1)
  204. NBELEM=NUM(/2)
  205. C
  206. C TRAITEMENT DU MODELE
  207. C
  208. C
  209. C COQUE INTEGREE OU PAS ?
  210. C
  211. IF(INFMOD(/1).NE.0)THEN
  212. NPINT=INFMOD(1)
  213. ELSE
  214. NPINT=0
  215. ENDIF
  216. IF (NPINT.NE.0)THEN
  217. CALL ERREUR(615)
  218. SEGDES IMODEL,MMODEL
  219. SEGSUP MCHELM
  220. RETURN
  221. ENDIF
  222. C
  223. C NATURE DU MATERIAU
  224. C
  225. C* NFOR=FORMOD(/2)
  226. C* NMAT=MATMOD(/2)
  227. C* CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INPLAS)
  228. CMATE = CMATEE
  229. MATE = IMATEE
  230. INPLAS = INATUU
  231. C* IF (CMATE.EQ.' ')THEN
  232. C* CALL ERREUR(251)
  233. C* SEGDES IMODEL,MMODEL
  234. C* SEGSUP MCHELM
  235. C* RETURN
  236. C* ENDIF
  237. C____________________________________________________________________
  238. C
  239. C INFORMATION SUR L'ELEMENT FINI
  240. C____________________________________________________________________
  241. C
  242. * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  243. * IF (IERR.NE.0) THEN
  244. * SEGDES IMODEL,MMODEL
  245. * SEGSUP MCHELM
  246. * RETURN
  247. * ENDIF
  248. MFR =INFELE(13)
  249. NBG =INFELE(6)
  250. NBGS =INFELE(4)
  251. NSTRS=INFELE(16)
  252. LRE =INFELE(9)
  253. IPPORE=0
  254. IF(MFR.EQ.33) IPPORE=NBNN
  255. LW =200
  256. LW2=150
  257. LHOOK=INFELE(10)
  258. LHOO2=LHOOK*LHOOK
  259. * MINTE=INFELE(11)
  260. minte=infmod(7)
  261. *
  262. IPMINT=MINTE
  263. SEGACT,MINTE
  264. *
  265. * REMPLISSAGE DES TABLEAUX INFCHE
  266. *
  267. INFCHE(ISOUS,1)=0
  268. INFCHE(ISOUS,2)=0
  269. INFCHE(ISOUS,3)=NHRM
  270. INFCHE(ISOUS,4)=MINTE
  271. INFCHE(ISOUS,5)=0
  272. INFCHE(ISOUS,6)=5
  273. C
  274. C CREATION DU TABLEAU INFOS
  275. C
  276. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  277. IF (IRTD.EQ.0)THEN
  278. SEGDES IMODEL,MMODEL
  279. SEGSUP MCHELM
  280. RETURN
  281. ENDIF
  282. *
  283. * TRAITEMENT DU CHAMP DE CONTRAINTES
  284. *
  285. if(lnomid(4).ne.0) then
  286. nomid=lnomid(4)
  287. segact nomid
  288. mostrs=nomid
  289. nstr=lesobl(/2)
  290. nfac=lesfac(/2)
  291. lsupco=.false.
  292. else
  293. lsupco=.true.
  294. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  295. endif
  296. IF (MOSTRS.EQ.0) THEN
  297. MOTERR(1:4)='CONT'
  298. MOTERR(5:8)=NOMTP(MELE)
  299. CALL ERREUR (76)
  300. SEGDES IMODEL,MMODEL
  301. SEGSUP MCHELM
  302. RETURN
  303. ENDIF
  304. *
  305. NBTYPE=1
  306. SEGINI NOTYPE
  307. MOTYPE=NOTYPE
  308. TYPE(1)='REAL*8'
  309. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  310. IF(IERR.NE.0)THEN
  311. SEGSUP NOTYPE
  312. KERRE=999
  313. GOTO 9990
  314. ENDIF
  315. *
  316. IF (ISUP1.EQ.1) THEN
  317. CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  318. IF(IERR.NE.0)THEN
  319. SEGSUP NOTYPE
  320. KERRE=999
  321. ISUP1=0
  322. GOTO 9990
  323. ENDIF
  324. ENDIF
  325. *
  326. * TRAITEMENT DU CHAMP DE VARIABLES INTERNES
  327. *
  328. if(lnomid(10).ne.0) then
  329. nomid=lnomid(10)
  330. segact nomid
  331. movari=nomid
  332. nvari=lesobl(/2)
  333. nvarf=lesfac(/2)
  334. else
  335. lsupva=.true.
  336. CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF)
  337. endif
  338.  
  339. IF (MOVARI.EQ.0) THEN
  340. MOTERR(1:4)='VARI'
  341. MOTERR(5:8)=NOMTP(MELE)
  342. CALL ERREUR (76)
  343. KERRE=999
  344. SEGSUP NOTYPE
  345. GOTO 9990
  346. ENDIF
  347. *
  348. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOVARI,MOTYPE,1,INFOS,3,IVARI)
  349. SEGSUP NOTYPE
  350. IF(IERR.NE.0)THEN
  351. KERRE=999
  352. GOTO 9990
  353. ENDIF
  354. *
  355. IF (ISUP2.EQ.1) THEN
  356. CALL VALCHE(IVARI,NVARI,IPMINT,IPPORE,MOVARI,MELE)
  357. IF(IERR.NE.0)THEN
  358. KERRE=999
  359. ISUP2=0
  360. GOTO 9990
  361. ENDIF
  362. ENDIF
  363. *
  364. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES
  365. *
  366. if(lnomid(6).ne.0) then
  367. nomid=lnomid(6)
  368. segact nomid
  369. momatr=nomid
  370. nmatr=lesobl(/2)
  371. nmatf=lesfac(/2)
  372. lsupma=.false.
  373. else
  374. lsupma=.true.
  375. CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
  376. endif
  377. IF (MOMATR.EQ.0) THEN
  378. MOTERR(1:4)='MATE'
  379. MOTERR(5:8)=NOMTP(MELE)
  380. CALL ERREUR (76)
  381. KERRE=999
  382. GOTO 9990
  383. ENDIF
  384. *
  385. NOTYPE=0
  386. IF(INPLAS.EQ.5)THEN
  387. NBTYPE=5
  388. SEGINI NOTYPE
  389. TYPE(1)='REAL*8'
  390. TYPE(2)='REAL*8'
  391. TYPE(3)='POINTEUREVOLUTIO'
  392. TYPE(4)='REAL*8'
  393. TYPE(5)='REAL*8'
  394. ELSE IF (INPLAS.EQ.14) THEN
  395. NBTYPE=9
  396. SEGINI NOTYPE
  397. TYPE(1)='REAL*8'
  398. TYPE(2)='REAL*8'
  399. TYPE(3)='REAL*8'
  400. TYPE(4)='REAL*8'
  401. TYPE(5)='REAL*8'
  402. TYPE(6)='POINTEUREVOLUTIO'
  403. TYPE(7)='POINTEUREVOLUTIO'
  404. TYPE(8)='REAL*8'
  405. TYPE(9)='REAL*8'
  406. ELSE IF (INPLAS.EQ.26) THEN
  407. NBTYPE=8
  408. SEGINI NOTYPE
  409. TYPE(1)='REAL*8'
  410. TYPE(2)='REAL*8'
  411. TYPE(3)='POINTEUREVOLUTIO'
  412. TYPE(4)='REAL*8'
  413. TYPE(5)='REAL*8'
  414. TYPE(6)='REAL*8'
  415. TYPE(7)='REAL*8'
  416. TYPE(8)='REAL*8'
  417. ELSEIF(INPLAS.EQ.29)THEN
  418. NBTYPE=13
  419. SEGINI NOTYPE
  420. TYPE(1)='REAL*8'
  421. TYPE(2)='REAL*8'
  422. TYPE(3)='REAL*8'
  423. TYPE(4)='REAL*8'
  424. TYPE(5)='REAL*8'
  425. TYPE(6)='REAL*8'
  426. TYPE(7)='REAL*8'
  427. TYPE(8)='REAL*8'
  428. TYPE(9)='REAL*8'
  429. TYPE(10)='POINTEUREVOLUTIO'
  430. TYPE(11)='REAL*8'
  431. TYPE(12)='REAL*8'
  432. TYPE(13)='REAL*8'
  433. ELSEIF(INPLAS.EQ.16)THEN
  434. NBTYPE=7
  435. SEGINI NOTYPE
  436. TYPE(1)='REAL*8'
  437. TYPE(2)='REAL*8'
  438. TYPE(3)='POINTEUREVOLUTIO'
  439. TYPE(4)='REAL*8'
  440. TYPE(5)='REAL*8'
  441. TYPE(6)='REAL*8'
  442. TYPE(7)='REAL*8'
  443. ELSEIF(INPLAS.EQ.2)THEN
  444. NBTYPE=6
  445. SEGINI NOTYPE
  446. TYPE(1)='REAL*8'
  447. TYPE(2)='REAL*8'
  448. TYPE(3)='REAL*8'
  449. TYPE(4)='POINTEUREVOLUTIO'
  450. TYPE(5)='REAL*8'
  451. TYPE(6)='REAL*8'
  452. ELSE
  453. NBTYPE=1
  454. SEGINI NOTYPE
  455. TYPE(1)='REAL*8'
  456. ENDIF
  457. MOTYPE=NOTYPE
  458. CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1,
  459. & INFOS,3,IVAMAT)
  460. SEGSUP NOTYPE
  461. IF(IERR.NE.0)THEN
  462. KERRE=999
  463. GOTO 9990
  464. ENDIF
  465. NMATT=NMATR+NMATF
  466. *
  467. IF (ISUP3.EQ.1) THEN
  468. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  469. IF(IERR.NE.0)THEN
  470. KERRE=999
  471. ISUP3=0
  472. GOTO 9990
  473. ENDIF
  474. ENDIF
  475. *
  476. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES
  477. *
  478. NBROBL=0
  479. NBRFAC=0
  480. NOMID =0
  481. IVECT=0
  482. *
  483. * COQUES MINCES
  484. *
  485. IF (MFR.EQ.3.OR.MFR.EQ.9) THEN
  486. NBROBL=1
  487. NBRFAC=2
  488. SEGINI NOMID
  489. LESOBL(1)='EPAI'
  490. LESFAC(1)='CALF'
  491. LESFAC(2)='EXCE'
  492. *
  493. NBTYPE=1
  494. SEGINI NOTYPE
  495. TYPE(1)='REAL*8'
  496. ELSEIF (MFR.EQ.5) THEN
  497. NBROBL=1
  498. NBRFAC=1
  499. SEGINI NOMID
  500. LESOBL(1)='EPAI'
  501. LESFAC(1)='EXCE'
  502. *
  503. NBTYPE=1
  504. SEGINI NOTYPE
  505. TYPE(1)='REAL*8'
  506. *
  507. * SECTION POUR LES BARRES
  508. *
  509. ELSE IF (MFR.EQ.27) THEN
  510. NBROBL=1
  511. SEGINI NOMID
  512. LESOBL(1)='SECT'
  513. *
  514. NBTYPE=1
  515. SEGINI NOTYPE
  516. TYPE(1)='REAL*8'
  517. *
  518. * CARACTERISTIQUES POUR LES POUTRES
  519. *
  520. ELSE IF (MFR.EQ.7 ) THEN
  521. NBROBL=4
  522. NBRFAC=6
  523. SEGINI NOMID
  524. LESOBL(1)='TORS'
  525. LESOBL(2)='INRY'
  526. LESOBL(3)='INRZ'
  527. LESOBL(4)='SECT'
  528. LESFAC(1)='SECY'
  529. LESFAC(2)='SECZ'
  530. LESFAC(3)='DX '
  531. LESFAC(4)='DY '
  532. LESFAC(5)='DZ '
  533. LESFAC(6)='VECT'
  534. IVECT=1
  535. *
  536. NBTYPE=10
  537. SEGINI NOTYPE
  538. TYPE(1)='REAL*8'
  539. TYPE(2)='REAL*8'
  540. TYPE(3)='REAL*8'
  541. TYPE(4)='REAL*8'
  542. TYPE(5)='REAL*8'
  543. TYPE(6)='REAL*8'
  544. TYPE(7)='REAL*8'
  545. TYPE(8)='REAL*8'
  546. TYPE(9)='REAL*8'
  547. TYPE(10)='POINTEURPOINT '
  548.  
  549. *
  550. * CARACTERISTIQUES POUR LES TUYAUX
  551. *
  552. ELSE IF (MFR.EQ.13) THEN
  553. NBROBL=2
  554. NBRFAC=9
  555. SEGINI NOMID
  556. LESOBL(1)='EPAI'
  557. LESOBL(2)='RAYO'
  558. LESFAC(1)='RACO'
  559. LESFAC(2)='PRES'
  560. LESFAC(3)='CISA'
  561. LESFAC(4)='CFFX'
  562. LESFAC(5)='CFMX'
  563. LESFAC(6)='CFMY'
  564. LESFAC(7)='CFMZ'
  565. LESFAC(8)='CFPR'
  566. LESFAC(9)='VECT'
  567. IVECT=1
  568. *
  569. NBTYPE=11
  570. SEGINI NOTYPE
  571. TYPE(1)='REAL*8'
  572. TYPE(2)='REAL*8'
  573. TYPE(3)='REAL*8'
  574. TYPE(4)='REAL*8'
  575. TYPE(5)='REAL*8'
  576. TYPE(6)='REAL*8'
  577. TYPE(7)='REAL*8'
  578. TYPE(8)='REAL*8'
  579. TYPE(9)='REAL*8'
  580. TYPE(10)='REAL*8'
  581. TYPE(11)='POINTEURPOINT '
  582. *
  583. * CARACTERISTIQUES POUR LES LINESPRING
  584. *
  585. ELSE IF (MFR.EQ.15) THEN
  586. NBROBL=5
  587. SEGINI NOMID
  588. LESOBL(1)='EPAI'
  589. LESOBL(2)='FISS'
  590. LESOBL(3)='VX '
  591. LESOBL(4)='VY '
  592. LESOBL(5)='VZ '
  593. *
  594. NBTYPE=1
  595. SEGINI NOTYPE
  596. TYPE(1)='REAL*8'
  597. *
  598. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  599. *
  600. ELSE IF (MFR.EQ.17) THEN
  601. NBROBL=9
  602. SEGINI NOMID
  603. LESOBL(1)='RAYO'
  604. LESOBL(2)='EPAI'
  605. LESOBL(3)='VX '
  606. LESOBL(4)='VY '
  607. LESOBL(5)='VZ '
  608. LESOBL(6)='VXF '
  609. LESOBL(7)='VYF '
  610. LESOBL(8)='VZF '
  611. LESOBL(9)='ANGL'
  612. *
  613. NBTYPE=1
  614. SEGINI NOTYPE
  615. TYPE(1)='REAL*8'
  616. *
  617. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  618. *
  619. ELSE IF (MFR.EQ.37) THEN
  620. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  621. NBROBL=4
  622. SEGINI NOMID
  623. LESOBL(1)='SCEL'
  624. LESOBL(2)='SFLU'
  625. LESOBL(3)='EPS '
  626. LESOBL(4)='XINE'
  627. ELSE
  628. NBROBL=3
  629. SEGINI NOMID
  630. LESOBL(1)='SCEL'
  631. LESOBL(2)='SFLU'
  632. LESOBL(3)='EPS '
  633. ENDIF
  634. *
  635. NBTYPE=1
  636. SEGINI NOTYPE
  637. TYPE(1)='REAL*8'
  638. ENDIF
  639. *
  640. MOCARA=NOMID
  641. NCARA=NBROBL
  642. NCARF=NBRFAC
  643. NCARR=NCARA+NCARF
  644.  
  645. IF(MOCARA.NE.0)THEN
  646. MOTYPE=NOTYPE
  647. CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1,
  648. & INFOS,3,IVACAR)
  649. SEGSUP NOTYPE
  650. IF(IERR.NE.0)THEN
  651. KERRE=999
  652. GOTO 9990
  653. ENDIF
  654. *
  655. IF (IVECT.EQ.1) THEN
  656. MPTVAL=IVACAR
  657. IF (IVAL(NCARR).EQ.0) THEN
  658. *
  659. * MOT CLE VECT EN CAS DE CONVERSION
  660. *
  661. IVECT=2
  662. NOMID=MOCARA
  663. SEGACT NOMID
  664. NBRFAC=NBRFAC+2
  665. SEGADJ NOMID
  666. MOCARA=NOMID
  667. LESFAC(NBRFAC-2)='VX '
  668. LESFAC(NBRFAC-1)='VY '
  669. LESFAC(NBRFAC )='VZ '
  670.  
  671. NCARF=NBRFAC
  672. NCARR=NCARA+NCARF
  673. *
  674. NBTYPE=1
  675. SEGINI NOTYPE
  676. MOTYPE=NOTYPE
  677. TYPE(1)='REAL*8'
  678. *
  679. CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  680. & IVACAR)
  681. SEGSUP NOTYPE
  682. IF (IERR.NE.0) THEN
  683. KERRE=999
  684. GOTO 9990
  685. ENDIF
  686. ENDIF
  687. ENDIF
  688. *
  689. IF (ISUP3.EQ.1) THEN
  690. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  691. IF(IERR.NE.0)THEN
  692. KERRE=999
  693. ISUP3=0
  694. GOTO 9990
  695. ENDIF
  696. ENDIF
  697. ENDIF
  698. ICARA=NCARR
  699. IF((MFR.EQ.7.OR.MFR.EQ.13).AND.IVECT.EQ.1)ICARA=NCARR+IDIM-1
  700. *
  701. * CREATION DES MCHAMLS DE LA SOUS ZONE
  702. *
  703. NBPTEL=NBGS
  704. NEL=NBELEM
  705. N1PTEL=NBPTEL
  706. N1EL=NEL
  707. *
  708. N2=1
  709. SEGINI MCHAML
  710. ICHAML(ISOUS)=MCHAML
  711. NOMCHE(1)='SCAL'
  712. TYPCHE(1)='REAL*8'
  713. N2PTEL=0
  714. N2EL=0
  715. SEGINI MELVAL
  716. IELVAL(1)=MELVAL
  717. IMELCR=MELVAL
  718. C
  719. C MISE A 0 DES VARIABLES DU COMMON NECOU SI BESOIN
  720. C LES BONNES VALEURS SONT ATTRIBUEES SELON LES MODELES
  721. C INITIALISATIONS SELON LES CAS
  722. C
  723. LTRAC=0
  724. IF(INPLAS.NE.2)THEN
  725. IFOURB=IFOUR
  726. NCOURB=0
  727. IPLAST=0
  728. IMAPLA=1
  729. IT=1
  730. ISOTRO=0
  731. ITYP=0
  732. C
  733. C CORRESPONDANCE ( MFR,IFOUR) ET ITYP FAITE DANS ECOCRI
  734. C
  735. IFLUAG=0
  736. ICINE=0
  737. ITHER=0
  738. IFLUPL=0
  739. ICYCL=0
  740. IBI=0
  741. JFLUAG=0
  742. KFLUAG=0
  743. LFLUAG=0
  744. IRELAX=0
  745. JNTRIN=0
  746. MFLUAG=0
  747. JSOUFL=0
  748. JGRDEF=0
  749. LTRAC=60
  750. ENDIF
  751. *
  752. * INITIALISATION DES SEGMENTS DE TRAVAIL
  753. *
  754. NCXMAT=NMATT
  755. IF(INPLAS.EQ.3)NCXMAT=NMATT+7
  756. SEGINI WRK0,WRK1,WRK2,WRK3
  757. IF(MFR.EQ.7.OR.MFR.EQ.13)THEN
  758. NBBB=NBNN
  759. SEGINI WRK4
  760. ENDIF
  761. *
  762. * BOUCLE SUR LES ELEMENTS
  763. *
  764. DO 200 IB=1,NBELEM
  765. *
  766. * BOUCLE SUR LES POINTS DE GAUSS
  767. *
  768. DO 300 IGAU=1,NBPTEL
  769. *
  770. * ON RECUPERE LES CONTRAINTES
  771. *
  772. MPTVAL=IVASTR
  773. DO 201 IC=1,NSTRS
  774. MELVAL=IVAL(IC)
  775. IBMN=MIN(IB,VELCHE(/2))
  776. IGMN=MIN(IGAU,VELCHE(/1))
  777. SIG0(IC)=VELCHE(IGMN,IBMN)
  778. 201 CONTINUE
  779. *
  780. * ON RECUPERE LES VARIABLES INTERNES
  781. *
  782. MPTVAL=IVARI
  783. DO 202 IC=1,NVARI
  784. MELVAL=IVAL(IC)
  785. IBMN=MIN(IB,VELCHE(/2))
  786. IGMN=MIN(IGAU,VELCHE(/1))
  787. VAR0(IC)=VELCHE(IGMN,IBMN)
  788. 202 CONTINUE
  789. *
  790. * ON RECUPERE LES CONSTANTES DU MATERIAU
  791. *
  792. MPTVAL=IVAMAT
  793. IF(INPLAS.EQ.9 .OR.INPLAS .EQ. 28)THEN
  794. *
  795. * POUR LE MODELE BETON ET UBIQUITOUS
  796. *
  797. DO 203 IC=1,NMATT
  798. MELVAL=IVAL(IC)
  799. IF(MELVAL.NE.0)THEN
  800. IBMN=MIN(IB,VELCHE(/2))
  801. IGMN=MIN(IGAU,VELCHE(/1))
  802. XMAT(IC)=VELCHE(IGMN,IBMN)
  803. ELSE
  804. XMAT(IC)=0.D0
  805. ENDIF
  806. 203 CONTINUE
  807. ELSE
  808. *
  809. * POUR LES AUTRES MODELES
  810. *
  811. MELVAL=IVAL(1)
  812. IF(MELVAL.NE.0)THEN
  813. IF(TYVAL(1)(1:8).NE.'POINTEUR')THEN
  814. IBMN=MIN(IB,VELCHE(/2))
  815. IGMN=MIN(IGAU,VELCHE(/1))
  816. XMAT(1)=VELCHE(IGMN,IBMN)
  817. ELSE
  818. IBMN=MIN(IB,IELCHE(/2))
  819. IGMN=MIN(IGAU,IELCHE(/1))
  820. XMAT(1)=IELCHE(IGMN,IBMN)
  821. ENDIF
  822. ELSE
  823. XMAT(1)=0.D0
  824. IF(TYVAL(1)(1:8).EQ.'POINTEUR') THEN
  825. XMAT(1)=0
  826. END IF
  827. ENDIF
  828. MELVAL=IVAL(2)
  829. IF(MELVAL.NE.0)THEN
  830. IF(TYVAL(2)(1:8).NE.'POINTEUR')THEN
  831. IBMN=MIN(IB,VELCHE(/2))
  832. IGMN=MIN(IGAU,VELCHE(/1))
  833. XMAT(2)=VELCHE(IGMN,IBMN)
  834. ELSE
  835. IBMN=MIN(IB,IELCHE(/2))
  836. IGMN=MIN(IGAU,IELCHE(/1))
  837. XMAT(2)=IELCHE(IGMN,IBMN)
  838. ENDIF
  839. ELSE
  840. XMAT(2)=0.D0
  841. IF(TYVAL(2)(1:8).EQ.'POINTEUR') THEN
  842. XMAT(2)=0
  843. END IF
  844. ENDIF
  845. DO 205 IC=3,NMATT-2
  846. MELVAL=IVAL(IC)
  847. IF(MELVAL.NE.0)THEN
  848. IF(TYVAL(IC)(1:8).NE.'POINTEUR')THEN
  849. IBMN=MIN(IB,VELCHE(/2))
  850. IGMN=MIN(IGAU,VELCHE(/1))
  851. XMAT(IC+2)=VELCHE(IGMN,IBMN)
  852. ELSE
  853. IBMN=MIN(IB,IELCHE(/2))
  854. IGMN=MIN(IGAU,IELCHE(/1))
  855. XMAT(IC+2)=IELCHE(IGMN,IBMN)
  856. ENDIF
  857. ELSE
  858. XMAT(IC+2)=0.D0
  859. IF(TYVAL(IC)(1:8).EQ.'POINTEUR') THEN
  860. XMAT(IC+2)=0
  861. END IF
  862. ENDIF
  863. 205 CONTINUE
  864. MELVAL=IVAL(NMATT-1)
  865. IF(MELVAL.NE.0)THEN
  866. IF(TYVAL(NMATT-1)(1:8).NE.'POINTEUR')THEN
  867. IBMN=MIN(IB,VELCHE(/2))
  868. IGMN=MIN(IGAU,VELCHE(/1))
  869. XMAT(3)=VELCHE(IGMN,IBMN)
  870. ELSE
  871. IBMN=MIN(IB,IELCHE(/2))
  872. IGMN=MIN(IGAU,IELCHE(/1))
  873. XMAT(3)=IELCHE(IGMN,IBMN)
  874. ENDIF
  875. ELSE
  876. XMAT(3)=0.D0
  877. IF(TYVAL(NMATT-1)(1:8).EQ.'POINTEUR')XMAT(3)=0
  878. END IF
  879. MELVAL=IVAL(NMATT)
  880. IF(MELVAL.NE.0)THEN
  881. IF(TYVAL(NMATT)(1:8).NE.'POINTEUR')THEN
  882. IBMN=MIN(IB,VELCHE(/2))
  883. IGMN=MIN(IGAU,VELCHE(/1))
  884. XMAT(4)=VELCHE(IGMN,IBMN)
  885. ELSE
  886. IBMN=MIN(IB,IELCHE(/2))
  887. IGMN=MIN(IGAU,IELCHE(/1))
  888. XMAT(4)=IELCHE(IGMN,IBMN)
  889. ENDIF
  890. ELSE
  891. XMAT(4)=0.D0
  892. IF(TYVAL(NMATT)(1:8).EQ.'POINTEUR') THEN
  893. XMAT(4)=0
  894. END IF
  895. ENDIF
  896. *
  897. * REARRANGEMENT POUR CERTAINES LOIS
  898. *
  899. IF (INPLAS.EQ.14) THEN
  900. IF(XMAT(8).NE.XZER.OR.XMAT(9).NE.XZER)THEN
  901. INPLAS=18
  902. XMAT(5)=XMAT(8)
  903. XMAT(6)=XMAT(9)
  904. ENDIF
  905. ELSE IF (INPLAS.EQ.2) THEN
  906. IF (XMAT(6).NE.XZER) THEN
  907. INPLAS=27
  908. XMAT(5)=XMAT(6)
  909. ENDIF
  910. ELSE IF (INPLAS.EQ.29)THEN
  911. YXMAT=XMAT(13)
  912. XMAT(13)=XMAT(4)
  913. XMAT(4)=XMAT(3)
  914. XMAT(3)=YXMAT
  915. ENDIF
  916. ENDIF
  917. *
  918. * ON RECUPERE LES CARACTERISTIQUES GEOMETRIQUES
  919. *
  920. IF(IVACAR.NE.0)THEN
  921. MPTVAL=IVACAR
  922. *
  923. * cas des tuyaux
  924. *
  925. IF(MFR.EQ.13)THEN
  926. DO 106 IC=1,5
  927. MELVAL=IVAL(IC)
  928. IF(MELVAL.NE.0)THEN
  929. IBMN=MIN(IB,VELCHE(/2))
  930. IGMN=MIN(IGAU,VELCHE(/1))
  931. XCAR(IC)=VELCHE(IGMN,IBMN)
  932. ELSE
  933. XCAR(IC)=0.D0
  934. ENDIF
  935. 106 CONTINUE
  936. IF(IVECT.EQ.1)THEN
  937. DO 107 IC=6,NCARR-1
  938. MELVAL=IVAL(IC)
  939. IF(MELVAL.NE.0)THEN
  940. IBMN=MIN(IB,VELCHE(/2))
  941. IGMN=MIN(IGAU,VELCHE(/1))
  942. XCAR(IC)=VELCHE(IGMN,IBMN)
  943. ELSE
  944. XCAR(IC)=-1.D0
  945. ENDIF
  946. 107 CONTINUE
  947. IF(IVAL(NCARR).NE.0)THEN
  948. MELVAL=IVAL(NCARR)
  949. IBMN=MIN(IB,IELCHE(/2))
  950. IGMN=MIN(IGAU,IELCHE(/1))
  951. IP=IELCHE(IGMN,IBMN)
  952. IREF=(IP-1)*(IDIM+1)
  953. DO 108 IC=1,IDIM
  954. XCAR(NCARR+IC-1)=XCOOR(IREF+IC)
  955. 108 CONTINUE
  956. ELSE
  957. DO 109 IC=1,IDIM
  958. XCAR(NCARR+IC-1)=0.D0
  959. 109 CONTINUE
  960. ENDIF
  961. ELSE
  962. DO 110 IC=6,10
  963. MELVAL=IVAL(IC)
  964. IF(MELVAL.NE.0)THEN
  965. IBMN=MIN(IB,VELCHE(/2))
  966. IGMN=MIN(IGAU,VELCHE(/1))
  967. XCAR(IC)=VELCHE(IGMN,IBMN)
  968. ELSE
  969. XCAR(IC)=-1.D0
  970. ENDIF
  971. 110 CONTINUE
  972. DO 111 IC=11,ICARA
  973. MELVAL=IVAL(IC)
  974. IF(MELVAL.NE.0)THEN
  975. IBMN=MIN(IB,VELCHE(/2))
  976. IGMN=MIN(IGAU,VELCHE(/1))
  977. XCAR(IC)=VELCHE(IGMN,IBMN)
  978. ELSE
  979. XCAR(IC)=0.D0
  980. ENDIF
  981. 111 CONTINUE
  982. ENDIF
  983. ELSE IF(MFR.EQ.7.AND.IVECT.EQ.1)THEN
  984. DO 206 IC=1,NCARR-1
  985. MELVAL=IVAL(IC)
  986. IF(MELVAL.NE.0)THEN
  987. IBMN=MIN(IB,VELCHE(/2))
  988. IGMN=MIN(IGAU,VELCHE(/1))
  989. XCAR(IC)=VELCHE(IGMN,IBMN)
  990. ELSE
  991. XCAR(IC)=0.D0
  992. ENDIF
  993. 206 CONTINUE
  994. IF(IVAL(NCARR).NE.0)THEN
  995. MELVAL=IVAL(NCARR)
  996. IBMN=MIN(IB,IELCHE(/2))
  997. IGMN=MIN(IGAU,IELCHE(/1))
  998. IP=IELCHE(IGMN,IBMN)
  999. IREF=(IP-1)*(IDIM+1)
  1000. DO 207 IC=1,IDIM
  1001. XCAR(NCARR+IC-1)=XCOOR(IREF+IC)
  1002. 207 CONTINUE
  1003. ELSE
  1004. DO 208 IC=1,IDIM
  1005. XCAR(NCARR+IC-1)=0.D0
  1006. 208 CONTINUE
  1007. ENDIF
  1008. ELSE
  1009. DO 209 IC=1,ICARA
  1010. MELVAL=IVAL(IC)
  1011. IF(MELVAL.NE.0)THEN
  1012. IBMN=MIN(IB,VELCHE(/2))
  1013. IGMN=MIN(IGAU,VELCHE(/1))
  1014. XCAR(IC)=VELCHE(IGMN,IBMN)
  1015. ELSE
  1016. XCAR(IC)=0.D0
  1017. ENDIF
  1018. 209 CONTINUE
  1019. ENDIF
  1020. *
  1021. * REARRANGEMENT DU TABLEAU XCAR POUR QU'ON AI LA MEME ORDRE
  1022. * QUE L'ANCIEN CHAMELEM
  1023. *
  1024. IF(MFR.EQ.7)THEN
  1025. IF(IDIM.EQ.2)THEN
  1026. VX=XCAR(ICARA-3)
  1027. VY=XCAR(ICARA-2)
  1028. XCAR(ICARA-3)=XCAR(ICARA-1)
  1029. XCAR(ICARA-2)=XCAR(ICARA)
  1030. XCAR(ICARA-1)=VX
  1031. XCAR(ICARA)=VY
  1032. ELSEIF(IDIM.EQ.3)THEN
  1033. VX=XCAR(ICARA-5)
  1034. VY=XCAR(ICARA-4)
  1035. VZ=XCAR(ICARA-3)
  1036. XCAR(ICARA-5)=XCAR(ICARA-2)
  1037. XCAR(ICARA-4)=XCAR(ICARA-1)
  1038. XCAR(ICARA-3)=XCAR(ICARA)
  1039. XCAR(ICARA-2)=VX
  1040. XCAR(ICARA-1)=VY
  1041. XCAR(ICARA)=VZ
  1042. ENDIF
  1043. ELSE IF(MFR.EQ.13)THEN
  1044. NWORK2 = 7
  1045. DO 210 IC=4,10
  1046. WORK2(IC-3)=XCAR(IC)
  1047. 210 CONTINUE
  1048. IF(IDIM.EQ.2)THEN
  1049. XCAR(4)=XCAR(ICARA-1)
  1050. XCAR(5)=XCAR(ICARA)
  1051. DO 211 IC=1,NWORK2
  1052. XCAR(IC+5)=WORK2(IC)
  1053. 211 CONTINUE
  1054. ELSE IF(IDIM.EQ.3)THEN
  1055. XCAR(4)=XCAR(ICARA-2)
  1056. XCAR(5)=XCAR(ICARA-1)
  1057. XCAR({=span style="color: #cc66cc;">6)=XCAR(ICARA)
  1058. DO 212 IC=1,NWORK2
  1059. XCAR(IC+6)=WORK2(IC)
  1060. 212 CONTINUE
  1061. ENDIF
  1062. ENDIF
  1063. ENDIF
  1064. *
  1065. IF(INPLAS.EQ.0) THEN
  1066. CRITER = 0.D0
  1067. GOTO 510
  1068. C
  1069. ELSE
  1070. C=======================================================================
  1071. C NUMERO DES ETIQUETTES :
  1072. C
  1073. C 1 A 99 POUR LES MODELES DE PLASTICITE ( INDICE INPLAS )
  1074. C
  1075. C=======================================================================
  1076. GOTO (1, 2, 3, 4, 5,99, 7,99,99,99, 7, 7, 7,14,15,99,99,99,99,99,
  1077. . 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  1078. . 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  1079. . 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),INPLAS
  1080. C
  1081. 99 CONTINUE
  1082. KERRE=999
  1083. MOTERR(1:4)=NOMAC(INPLAS)
  1084. MOTERR(5:12)=NOMFR(MFR)
  1085. CALL ERREUR(269)
  1086. SEGSUP WRK0,WRK1,WRK2,WRK3
  1087. IF(MFR.EQ.7.OR.MFR.EQ.13)SEGSUP WRK4
  1088. GOTO 9990
  1089. C
  1090. C MODELE VON MISES ISOTROPE ASSOCIE ( D'APRES INCA )
  1091. C
  1092. 1 CONTINUE
  1093. C
  1094. C CAS DE LA PLASTICITE PARFAITE
  1095. C
  1096. NCOURB=2
  1097. TRAC(1)=XMAT(5)
  1098. TRAC(2)=0.D0
  1099. TRAC(3)=XMAT(5)
  1100. TRAC(4)=1.D0
  1101. IF(XMAT(5).EQ.XZER) THEN
  1102. KERRE=33
  1103. GO TO 510
  1104. ENDIF
  1105. GOTO 682
  1106. C
  1107. 3 CONTINUE
  1108. C
  1109. C CAS DU MODELE DE DRUCKER-PRAGER PARFAIT
  1110. C LES DONNEES SONT LES LIMITES EN TRACTION ET EN COMPRESSION
  1111. C
  1112. IMAPLA=5
  1113. DEN = ABS(XMAT(6)) + XMAT(5)
  1114. IF(DEN.EQ.0.D0) THEN
  1115. KERRE=48
  1116. GO TO 510
  1117. ENDIF
  1118. XMAT(7) = 2.0D0*ABS(XMAT(6))*XMAT(5)/DEN
  1119. XMAT(5) = (ABS(XMAT(6)) - XMAT(5))/DEN
  1120. XMAT(6) = SQRT(3.D0)
  1121. XMAT(8)=XMAT(5)
  1122. XMAT(9)=XMAT(6)
  1123. XMAT(10)=XMAT(5)
  1124. XMAT(11)=XMAT(6)
  1125. XMAT(12)=XMAT(7)
  1126. XMAT(13)=0.D0
  1127. C PETITS TESTS SUR LES DONNEES
  1128. IF(XMAT(10)/(XMAT(11)+1.D-20).GT.XMAT(5)*1.01/(XMAT(6)+1.D-20)
  1129. . .OR.XMAT(12).GT.XMAT(7)*1.01 ) THEN
  1130. KERRE=48
  1131. GO TO 510
  1132. ENDIF
  1133. GOTO 682
  1134. C
  1135. 4 CONTINUE
  1136. C
  1137. C CAS DE LA PLASTICITE CINEMATIQUE BILINEAIRE
  1138. C
  1139. ICINE=1
  1140. NCOURB=2
  1141. TRAC(1)=XMAT(5)
  1142. TRAC(2)=0.D0
  1143. TRAC(3)=XMAT(5)+XMAT(6)
  1144. TRAC(4)=1.D0
  1145. IF(XMAT(5).EQ.0.D0) THEN
  1146. KERRE=33
  1147. GO TO 510
  1148. ENDIF
  1149. GOTO 682
  1150. C
  1151. 5 CONTINUE
  1152. C
  1153. C CAS DE LA PLASTICITE ISOTROPE ECROUISSABLE
  1154. C
  1155. C ON RECUPERE LA COURBE DE TRACTION
  1156. C
  1157. nccor=ncourb
  1158. CALL COTRAC(WRK0,WRK2,NCcor,KERRE)
  1159. ncourb=nccor
  1160. IF(KERRE.NE.0) GO TO 510
  1161. GO TO 682
  1162. C
  1163. 7 CONTINUE
  1164. C
  1165. C CAS DU MODELE CHABOCHE
  1166. C
  1167. ICINE=1
  1168. IMAPLA=4
  1169. GOTO 682
  1170. C
  1171. 15 CONTINUE
  1172. C
  1173. C CAS DU MODELE DE DRUCKER-PRAGER GENERAL
  1174. C
  1175. IMAPLA=5
  1176. C PAS D'INITIALISATIONS PAR DEFAUT POUR LE MOMENT
  1177. C IF(XMAT(8).EQ.0.) XMAT(8)=XMAT(5)
  1178. C IF(XMAT(9).EQ.0.) XMAT(9)=XMAT(6)
  1179. C IF(XMAT(10).EQ.0.) XMAT(10)=XMAT(5)
  1180. C IF(XMAT(11).EQ.0.) XMAT(11)=XMAT(6)
  1181. C IF(XMAT(12).EQ.0.) XMAT(12)=XMAT(7)
  1182. C PETITS TESTS SUR LES DONNEES
  1183. IF(XMAT(10)/(XMAT(11)+1.D-20).GT.XMAT(5)*1.01/(XMAT(6)+1.D-20)
  1184. . .OR.XMAT(12).GT.XMAT(7)*1.01 ) THEN
  1185. KERRE=48
  1186. GO TO 510
  1187. ENDIF
  1188. C PERMUTATIONS POUR ECOCRI
  1189. DO 615 I=5,7
  1190. WW=XMAT(I)
  1191. XMAT(I)=XMAT(I+5)
  1192. 615 XMAT(I+5)=WW
  1193. GOTO 682
  1194. C
  1195. 682 CONTINUE
  1196. DO 675 IC=1,ICARA
  1197. 675 WORK(IC)=XCAR(IC)
  1198. BID(1)=0.D00
  1199. BID(2)=0.D00
  1200. BID(3)=0.D00
  1201. necobi=necou
  1202. neecbi=ecou
  1203. CALL ECOCRI(SIG0,VAR0,BID,XMAT,CRITER,WORK ,
  1204. . TRAC,KERRE,MFR,NSTRS,INPLAS,necou,ecou)
  1205. IF(KERRE.EQ.99) GO TO 99
  1206. GOTO 510
  1207. C
  1208. C MODELE LINESPRING
  1209. C
  1210. 2 CONTINUE
  1211. CALL LISCRI(SIG0,XMAT,XCAR,KERRE,CRITER)
  1212. GOTO 510
  1213. C
  1214. C TUYAU FISSURE
  1215. C
  1216. 14 CONTINUE
  1217. CALL TUFCRI(SIG0,VAR0,XMAT,XCAR,KERRE,CRITER)
  1218. GOTO 510
  1219. ENDIF
  1220. C
  1221. 510 CONTINUE
  1222. IF(KERRE.NE.0) THEN
  1223. C
  1224. C IMPRESSION DE QUELQUES MESSAGES D ERREURS
  1225. C
  1226. INTERR(1)=IB
  1227. INTERR(2)=IGAU
  1228. MOTERR(1:4)=NOMTP(MELE)
  1229. IF(KERRE.EQ.1) CALL ERREUR(267)
  1230. IF(KERRE.EQ.2) CALL ERREUR(268)
  1231. IF(KERRE.EQ.7) CALL ERREUR(355)
  1232. IF(KERRE.EQ.30) CALL ERREUR(270)
  1233. IF(KERRE.EQ.31) CALL ERREUR(271)
  1234. IF(KERRE.EQ.32) CALL ERREUR(272)
  1235. IF(KERRE.EQ.33) CALL ERREUR(273)
  1236. IF(KERRE.EQ.34) CALL ERREUR(325)
  1237. IF(KERRE.EQ.35) CALL ERREUR(331)
  1238. IF(KERRE.EQ.36) CALL ERREUR(330)
  1239. IF(KERRE.EQ.37) CALL ERREUR(354)
  1240. IF(KERRE.EQ.38) CALL ERREUR(360)
  1241. IF(KERRE.EQ.48) CALL ERREUR(366)
  1242. IF(KERRE.EQ.75) CALL ERREUR(876)
  1243. SEGSUP WRK0,WRK1,WRK2,WRK3
  1244. IF(MFR.EQ.7.OR.MFR.EQ.13)SEGSUP WRK4
  1245. GO TO 9990
  1246. ENDIF
  1247. C
  1248. C REMPLISSAGE DU SEGMENT
  1249. C
  1250. MELVAL=IMELCR
  1251. VELCHE(IGAU,IB)=CRITER
  1252. C
  1253. 300 CONTINUE
  1254. 200 CONTINUE
  1255. SEGSUP WRK0,WRK1,WRK2,WRK3
  1256. IF(MFR.EQ.7.OR.MFR.EQ.13)SEGSUP WRK4
  1257. 9990 CONTINUE
  1258. *
  1259. * DESACTIVATION DES SEGMENTS
  1260. *
  1261. SEGDES MELEME,IMODEL
  1262. SEGDES,MINTE
  1263. *
  1264. IF(ISUP1.EQ.1)THEN
  1265. CALL DTMVAL (IVASTR,3)
  1266. ELSE
  1267. CALL DTMVAL (IVASTR,1)
  1268. ENDIF
  1269. IF(ISUP2.EQ.1)THEN
  1270. CALL DTMVAL (IVARI,3)
  1271. ELSE
  1272. CALL DTMVAL (IVARI,1)
  1273. ENDIF
  1274. IF(ISUP3.EQ.1)THEN
  1275. CALL DTMVAL (IVAMAT,3)
  1276. ELSE
  1277. CALL DTMVAL (IVAMAT,1)
  1278. ENDIF
  1279. IF(ISUP3.EQ.1)THEN
  1280. CALL DTMVAL (IVACAR,3)
  1281. ELSE
  1282. CALL DTMVAL (IVACAR,1)
  1283. ENDIF
  1284. *
  1285. IF (MOCARA.NE.0) THEN
  1286. NOMID=MOCARA
  1287. SEGSUP NOMID
  1288. END IF
  1289. *
  1290. IF (MOMATR.NE.0) THEN
  1291. NOMID=MOMATR
  1292. if(lsupma)SEGSUP NOMID
  1293. END IF
  1294. *
  1295. IF (MOVARI.NE.0) THEN
  1296. NOMID=MOVARI
  1297. if(lsupva)SEGSUP NOMID
  1298. END IF
  1299. *
  1300. IF (MOSTRS.NE.0) THEN
  1301. NOMID=MOSTRS
  1302. if(lsupco)SEGSUP NOMID
  1303. END IF
  1304. *
  1305. segsup necou,ecou
  1306. IF(KERRE.EQ.0)THEN
  1307. MELVAL=IMELCR
  1308. SEGDES MELVAL
  1309. SEGDES MCHAML
  1310. ELSE
  1311. MELVAL=IMELCR
  1312. SEGSUP MELVAL
  1313. SEGSUP MCHAML
  1314. GO TO 888
  1315. ENDIF
  1316. 500 CONTINUE
  1317. *
  1318. 888 CONTINUE
  1319. SEGDES MMODEL
  1320. IF(KERRE.EQ.0)THEN
  1321. SEGDES MCHELM
  1322. ELSE
  1323. SEGSUP MCHELM
  1324. ENDIF
  1325. *
  1326. RETURN
  1327. END
  1328.  
  1329.  
  1330.  
  1331.  
  1332.  
  1333.  

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