Télécharger critp.eso

Retour à la liste

Numérotation des lignes :

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

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