Télécharger elas1.eso

Retour à la liste

Numérotation des lignes :

elas1
  1. C ELAS1 SOURCE PV090527 23/06/12 21:15:02 11673
  2.  
  3. SUBROUTINE ELAS1(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPSTRS,IRET)
  4.  
  5. C_______________________________________________________________________
  6. C
  7. C operateur elasticite
  8. C
  9. C entrees :
  10. C ---------
  11. C
  12. C ipmodl pointeur sur un mmodel
  13. C ipche1 pointeur sur un mchaml de contraintes ou de deformations
  14. C ipche2 pointeur sur un mchaml de materiau
  15. C ipche3 pointeur sur un mchaml de variables internes(facultatif)
  16. C
  17. C sortie :
  18. C --------
  19. C
  20. C ipstrs pointeur sur un mchaml de contraintes ou de deformations
  21. C iret =1 ou 0 suivant succes ou pas
  22. C
  23. C passage aux nouveaux chamelem par jm campenon le 01/91
  24. C_______________________________________________________________________
  25. C
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28. C
  29. -INC CCREEL
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC CCHAMP
  34. -INC SMINTE
  35. -INC SMMODEL
  36. -INC SMELEME
  37. -INC SMCHAML
  38. -INC SMCOORD
  39. -INC SMLREEL
  40. C
  41. C_______________________________________________________________________
  42. C la variable kerre regit les impressions d erreurs dans elas1
  43. C
  44. C kerre=0 tout ok
  45. C =49 matrice de hooke singuliere
  46. C_______________________________________________________________________
  47. C
  48. SEGMENT IWRK1
  49. REAL*8 VALCAR(NCARRw),VALMAT(NMATT),VAR(NVART)
  50. REAL*8 SIGF(NSTRS),EPSI(NSTRS)
  51. REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK)
  52. REAL*8 COBMA(LHOOK)
  53. ENDSEGMENT
  54. C
  55. SEGMENT WPOUT
  56. REAL*8 SIG1(NSTRS),SIG2(NSTRS)
  57. ENDSEGMENT
  58. C
  59. SEGMENT IWRK2
  60. REAL*8 XE(3,NBNN),TXR(IDIM,IDIM)
  61. REAL*8 XLOC(3,3),XGLOB(3,3)
  62. REAL*8 D1HOOK(LHOOK,LHOOK),ROTHOO(LHOOK,LHOOK)
  63. REAL*8 COBAUX(LHOOK)
  64. ENDSEGMENT
  65. C
  66. SEGMENT IWRK4
  67. REAL*8 VECO1(LHOOK),VECO2(LHOOK)
  68. ENDSEGMENT
  69. C
  70. SEGMENT NOTYPE
  71. CHARACTER*16 TYPE(NBTYPE)
  72. ENDSEGMENT
  73. C
  74. SEGMENT MPTVAL
  75. INTEGER IPOS(NS) ,NSOF(NS)
  76. INTEGER IVAL(NCOSOU)
  77. CHARACTER*16 TYVAL(NCOSOU)
  78. ENDSEGMENT
  79. C
  80. DIMENSION CRIGI(12),CMASS(12),S(20)
  81. CHARACTER*8 CMATE
  82. C CHARACTER*8 PHAM
  83. CHARACTER*(NCONCH) CONM
  84. LOGICAL LSUPDE,LSUPCO,lsupma,lsupca,lsupre,lsupin,lsupva
  85. PARAMETER ( NINF=3 )
  86. PARAMETER(DEUX=2.D0,UNDEMI=.5D0,SIX=6.D0)
  87. PARAMETER(X774=.774596669241483D0)
  88. INTEGER INFOS(NINF)
  89. C
  90. IRET=0
  91. KERRE=0
  92. C
  93. C Verification de l'ordonnancement des MCHAML
  94. C On garde le MCHAML de EPSI/SIGM actif
  95. MCHELM=IPCHE1
  96. IF (TITCHE.EQ.'CARACTERISTIQUES') THEN
  97. IPCHE0=IPCHE2
  98. IPCHE2=IPCHE1
  99. IPCHE1=IPCHE0
  100. MCHELM=IPCHE1
  101. IF (IPCHE3.NE.0) THEN
  102. IF (TITCHE.EQ.'VARIABLES INTERNES') THEN
  103. IPCHE0=IPCHE3
  104. IPCHE3=IPCHE1
  105. IPCHE1=IPCHE0
  106. ENDIF
  107. ENDIF
  108. ELSE IF (TITCHE.EQ.'VARIABLES INTERNES') THEN
  109. IF (IPCHE3.NE.0) THEN
  110. IPCHE0=IPCHE3
  111. IPCHE3=IPCHE1
  112. IPCHE1=IPCHE0
  113. MCHEL2=IPCHE2
  114. IF (MCHEL2.TITCHE.NE.'CARACTERISTIQUES') THEN
  115. IPCHE0=IPCHE2
  116. IPCHE2=IPCHE1
  117. IPCHE1=IPCHE0
  118. ENDIF
  119. ELSE
  120. CC Pas de IPCHE3 mais IPCHE1 = VARINTER !
  121. CC Si IPCHE2 pas CARACT., je permute IPCHE1 & IPCHE2
  122. MCHEL2=IPCHE2
  123. IF (MCHEL2.TITCHE.NE.'CARACTERISTIQUES') THEN
  124. IPCHE0=IPCHE2
  125. IPCHE2=IPCHE1
  126. IPCHE1=IPCHE0
  127. ENDIF
  128. ENDIF
  129. ELSE IF (TITCHE.EQ.'CONTRAINTES'.OR.TITCHE.EQ.'DEFORMATIONS') THEN
  130. IF (IPCHE3.NE.0) THEN
  131. MCHEL2=IPCHE2
  132. IF (MCHEL2.TITCHE.NE.'CARACTERISTIQUES') THEN
  133. IPCHE0=IPCHE2
  134. IPCHE2=IPCHE3
  135. IPCHE3=IPCHE0
  136. ENDIF
  137. ENDIF
  138. ELSE
  139. CC IPCHE1 n'a pas un des sous-types attendus
  140. CC On essaie si on peut avoir ce qu'il faut avec IPCHE3
  141. CC en permuttant eventuellement IPCHE2 et IPCH3
  142. IF (IPCHE3.NE.0) THEN
  143. MCHEL2=IPCHE2
  144. IF (MCHEL2.TITCHE.EQ.'CARACTERISTIQUES') THEN
  145. IPCHE1=IPCHE3
  146. ELSE
  147. MCHEL3=IPCHE3
  148. IF (MCHEL3.TITCHE.EQ.'CARACTERISTIQUES') THEN
  149. IPCHE1=IPCHE2
  150. IPCHE2=IPCHE3
  151. ELSE IF (MCHEL3.TITCHE.NE.'VARIABLES INTERNES') THEN
  152. IPCHE1=IPCHE3
  153. ENDIF
  154. ENDIF
  155. ELSE
  156. IPCHE0=IPCHE2
  157. IPCHE2=IPCHE1
  158. IPCHE1=IPCHE0
  159. ENDIF
  160. ENDIF
  161. C
  162. C Verification du type de IPCHE1 :
  163. C KCAS = 1 ou 2 par la suite !
  164. MCHELM=IPCHE1
  165. IF (TITCHE.EQ.'CONTRAINTES') THEN
  166. KCAS = 2
  167. ELSE IF (TITCHE.EQ.'DEFORMATIONS') THEN
  168. KCAS = 1
  169. ELSE
  170. KCAS = 0
  171. MOTERR(1:24)='CONTRAINTES'
  172. MOTERR(25:48)='DEFORMATIONS'
  173. CALL ERREUR(109)
  174. RETURN
  175. ENDIF
  176. C
  177. C activation du modele
  178. C on cree un second modele ou on ne conserve que les sous-modeles
  179. c d'interet pour la suite. (A detruire a la fin)
  180. C
  181. MMODEL = IPMODL
  182. N1 = MMODEL.KMODEL(/1)
  183. SEGINI,MMODE2
  184. NSOUS = 0
  185. DO ISOUS = 1, N1
  186. IMODEL = MMODEL.KMODEL(ISOUS)
  187. IF (FORMOD(1).EQ.'MECANIQUE' .OR.
  188. & FORMOD(1).EQ.'POREUX' .OR.
  189. & FORMOD(1).EQ.'ELECTROSTATIQUE' .OR.
  190. & FORMOD(1).EQ.'DIFFUSION') THEN
  191. IF ((NEFMOD.NE.22).AND.(NEFMOD.NE.259)) THEN
  192. NSOUS = NSOUS + 1
  193. MMODE2.KMODEL(NSOUS) = IMODEL
  194. ENDIF
  195. ENDIF
  196. ENDDO
  197. N1 = NSOUS
  198. SEGADJ MMODE2
  199. IPMOD2 = MMODE2
  200. IF (NSOUS.LE.0) THEN
  201. CALL ERREUR(-182)
  202. CALL ERREUR(21)
  203. GOTO 9992
  204. ENDIF
  205. C
  206. C Verification du lieu support des mchamls
  207. C
  208. CALL QUESUP(IPMOD2,IPCHE1,5,0,ISUP1,IRET1)
  209. IF (ISUP1.GT.1) RETURN
  210. CALL QUESUP(IPMOD2,IPCHE2,5,0,ISUP2,IRET2)
  211. IF (ISUP2.GT.1) RETURN
  212. IF (IPCHE3.NE.0) THEN
  213. CALL QUESUP(IPMOD2,IPCHE3,5,0,ISUP3,IRET3)
  214. IF (ISUP3.GT.1) RETURN
  215. ENDIF
  216. C
  217. C creation du mchelm
  218. C
  219. N1 = NSOUS
  220. N3=6
  221. IF (KCAS.EQ.1) THEN
  222. L1=11
  223. SEGINI MCHEL1
  224. MCHEL1.TITCHE='CONTRAINTES'
  225. C* ELSE IF (KCAS.EQ.2) THEN
  226. ELSE
  227. L1=12
  228. SEGINI MCHEL1
  229. MCHEL1.TITCHE='DEFORMATIONS'
  230. ENDIF
  231. MCHEL1.IFOCHE=IFOUR
  232. IPSTRS=MCHEL1
  233. C
  234. C_______________________________________________________________________
  235. C
  236. C debut de la boucle sur les differentes sous zones
  237. C_______________________________________________________________________
  238. C Attention on boucle sur les NSOUS sous-modeles de IPMOD2 = MMODE2 !
  239. C SP : IVARES, MCHAM1 : correction fiche 8444
  240. IVARES = 0
  241. MCHAM1 = 0
  242.  
  243. DO 500 ISOUS = 1, NSOUS
  244. C
  245. IMODEL = MMODE2.KMODEL(ISOUS)
  246. C
  247. C traitement du modele
  248. C
  249. lsupma=.true.
  250. lsupva=.true.
  251. NMATR=0
  252. NMATF=0
  253. NCARA=0
  254. NCARF=0
  255. NVART=0
  256. MORES=0
  257. NRES=0
  258. IVAMAT=0
  259. IVACAR=0
  260. IVARI=0
  261. MOMATR=0
  262. MOCARA=0
  263. MOVARI=0
  264. C
  265. C on recupere l'information generale
  266. C
  267. MELE =NEFMOD
  268. IPMAIL=IMAMOD
  269. CONM =CONMOD
  270. C PHAM = conmod(17:24)
  271. C
  272. C creation du tableau infos
  273. C
  274. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  275. IF (IRTD.EQ.0) GOTO 9991
  276. C
  277. MELEME=IPMAIL
  278. NBNN=NUM(/1)
  279. NBELEM=NUM(/2)
  280. C
  281. C coque integree ou pas
  282. C
  283. IF(INFMOD(/1).NE.0) THEN
  284. NPINT=INFMOD(1)
  285. ELSE
  286. NPINT=0
  287. ENDIF
  288. C
  289. C information sur l'element fini
  290. C
  291. MFR =INFELE(13)
  292. NBPGAU=INFELE(6)
  293. IF ((MELE.EQ.29.OR.MFR.EQ.13).
  294. 1 AND.NBPGAU.NE.1.AND.NBPGAU.NE.2) THEN
  295. CALL ERREUR(712)
  296. GOTO 9991
  297. ENDIF
  298. NSTRS=INFELE(16)
  299. LHOOK=INFELE(10)
  300. IPORE=INFELE(8)
  301. IPPORE=0
  302. NBNO=NBNN
  303. IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  304. IPPORE=NBNN
  305. NBNO=IPORE
  306. ENDIF
  307. C
  308. C cas des dkt integres
  309. C
  310. IF (MFR.EQ.3.AND.NPINT.NE.0) LHOOK=4
  311. C
  312. C LHOO2=LHOOK*LHOOK
  313. C MINTE=INFELE(11)
  314. minte=infmod(7)
  315. IPMINT=MINTE
  316. C
  317. C nature du materiau
  318. C
  319. CMATE = CMATEE
  320. MATE = IMATEE
  321. INAT = INATUU
  322. C* IF (CMATE.EQ.' ') THEN
  323. C* CALL ERREUR(251)
  324. C* GOTO 9991
  325. C* ENDIF
  326. C
  327. MCHEL1.IMACHE(ISOUS)=IPMAIL
  328. MCHEL1.CONCHE(ISOUS)=CONMOD
  329. C
  330. MCHEL1.INFCHE(ISOUS,1)=0
  331. MCHEL1.INFCHE(ISOUS,2)=0
  332. MCHEL1.INFCHE(ISOUS,3)=NIFOUR
  333. MCHEL1.INFCHE(ISOUS,4)=MINTE
  334. MCHEL1.INFCHE(ISOUS,5)=0
  335. MCHEL1.INFCHE(ISOUS,6)=5
  336. C
  337. C recherche du nom des composantes
  338. C
  339. lsupre=.false.
  340. lsupin=.false.
  341. IF(lnomid(5).ne.0) then
  342. nomid=lnomid(5)
  343. nstdef=lesobl(/2)
  344. lsupde=.false.
  345. mosdef=nomid
  346. else
  347. CALL IDDEFO(IMODEL,IFOUR,MOSDEF,NSTDEF,NFADEF)
  348. lsupde=.true.
  349. endif
  350. if(lnomid(4).ne.0) then
  351. nomid=lnomid(4)
  352. mostr=nomid
  353. nst=lesobl(/2)
  354. nfac=lesfac(/2)
  355. lsupco=.false.
  356. else
  357. lsupco=.true.
  358. CALL IDCONT(IMODEL,IFOUR,MOstr,Nst,NFAC)
  359. endif
  360. IF (KCAS.EQ.1) THEN
  361. MOSTRS=MOSDEF
  362. NSTR=NSTDEF
  363. lsupin=lsupde
  364. mores = mostr
  365. nres=nst
  366. lsupre=lsupco
  367. C* ELSE IF (KCAS.EQ.2) THEN
  368. ELSE
  369. lsupin=lsupco
  370. MOSTRS=MOSTR
  371. NSTR=NST
  372. MORES=MOSDEF
  373. NRES=NSTDEF
  374. lsupre=lsupde
  375. ENDIF
  376. C
  377. C verification de leur presence
  378. C
  379. NBTYPE=1
  380. SEGINI NOTYPE
  381. MOTYPE=NOTYPE
  382. TYPE(1)='REAL*8'
  383. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  384. SEGSUP NOTYPE
  385. IF (IERR.NE.0) THEN
  386. NRES=0
  387. ISUP1 = 0
  388. GOTO 9990
  389. ENDIF
  390. C
  391. IF(ISUP1.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,
  392. & MOSTRS,MELE)
  393. C
  394. C recherche de la taille des melval a allouer
  395. C
  396. N1PTEL=NBPGAU
  397. N1EL =NBELEM
  398. NBPTEL=N1PTEL
  399. N2PTEL=0
  400. N2EL =0
  401. C
  402. C creation du mchaml de la sous zone
  403. C
  404. call oooprl(1)
  405. N2=NRES
  406. SEGINI MCHAM1
  407. MCHEL1.ICHAML(ISOUS)=MCHAM1
  408. NS=1
  409. NCOSOU=NRES
  410. SEGINI MPTVAL
  411. IVARES=MPTVAL
  412. NOMID=MORES
  413. DO 1000 ICOMP=1,NRES
  414. MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  415. MCHAM1.TYPCHE(ICOMP)='REAL*8'
  416. SEGINI MELVA1
  417. MCHAM1.IELVAL(ICOMP)=MELVA1
  418. IVAL(ICOMP)=MELVA1
  419. 1000 CONTINUE
  420. call oooprl(0)
  421. C
  422. C traitement des champs de materiau
  423. C
  424. NOMID=0
  425. NBROBL=0
  426. NBRFAC=0
  427. IF (FORMOD(1).EQ.'MECANIQUE') THEN
  428. C* IF (CMATE.EQ.'ISOTROPE') THEN
  429. IF (MATE.EQ.1) THEN
  430. IF(INAT.EQ.26.AND.IPCHE3.NE.0) THEN
  431. NBROBL=3
  432. NBRFAC=0
  433. SEGINI NOMID
  434. LESOBL(1)='YOUN'
  435. LESOBL(2)='NU '
  436. LESOBL(3)='DC '
  437. ELSEIF(INAT.EQ.62) THEN
  438. NBROBL=4
  439. NBRFAC=0
  440. SEGINI NOMID
  441. LESOBL(1)='YOUN'
  442. LESOBL(2)='NU '
  443. LESOBL(3)='F'
  444. LESOBL(4)='FC'
  445. ELSE
  446. NBROBL=2
  447. NBRFAC=0
  448. SEGINI NOMID
  449. IF (MFR.EQ.35) THEN
  450. LESOBL(1)='KS '
  451. LESOBL(2)='KN '
  452. ELSE
  453. LESOBL(1)='YOUN'
  454. LESOBL(2)='NU '
  455. ENDIF
  456. ENDIF
  457. C* ELSEIF (CMATE.EQ.'ORTHOTRO') THEN
  458. ELSEIF (MATE.EQ.2) THEN
  459. IF (MFR.EQ.75) THEN
  460. C
  461. C JOINT UNIDIMENSIONNEL JOI1
  462. C
  463. IF(IDIM.EQ.3)THEN
  464. NBROBL=12
  465. NBRFAC=0
  466. SEGINI NOMID
  467. LESOBL(1)='V1X '
  468. LESOBL(2)='V1Y '
  469. LESOBL(3)='V1Z '
  470. LESOBL(4)='V2X '
  471. LESOBL(5)='V2Y '
  472. LESOBL(6)='V2Z '
  473. LESOBL(7)='KN '
  474. LESOBL(8)='KS1 '
  475. LESOBL(9)='KS2'
  476. LESOBL(10)='QN '
  477. LESOBL(11)='QS1 '
  478. LESOBL(12)='QS2 '
  479. C
  480. ELSE IF(IDIM.EQ.2)THEN
  481. NBROBL=5
  482. NBRFAC=0
  483. SEGINI NOMID
  484. LESOBL(1)='V1X '
  485. LESOBL(2)='V1Y '
  486. LESOBL(3)='KN '
  487. LESOBL(4)='KS '
  488. LESOBL(5)='QS'
  489. ENDIF
  490. C
  491. ELSE IF (MFR.EQ.3) THEN
  492. C coques minces
  493. NBROBL=6
  494. NBRFAC=0
  495. SEGINI NOMID
  496. LESOBL(1)='YG1 '
  497. LESOBL(2)='YG2 '
  498. LESOBL(3)='NU12'
  499. LESOBL(4)='G12 '
  500. LESOBL(5)='V1X '
  501. LESOBL(6)='V1Y '
  502. ELSE IF (MFR.EQ.9.OR.MFR.EQ.5) THEN
  503. C coques avec cisaillement transverse
  504. NBROBL=8
  505. NBRFAC=0
  506. SEGINI NOMID
  507. LESOBL(1)='YG1 '
  508. LESOBL(2)='YG2 '
  509. LESOBL(3)='NU12'
  510. LESOBL(4)='G12 '
  511. LESOBL(5)='G23 '
  512. LESOBL(6)='G13 '
  513. LESOBL(7)='V1X '
  514. LESOBL(8)='V1Y '
  515. ELSE IF (MFR.EQ.1.OR.MFR.EQ.31) THEN
  516. C elements massifs
  517. IF(IDIM.EQ.3)THEN
  518. C elements 3d
  519. NBROBL=15
  520. NBRFAC=0
  521. SEGINI NOMID
  522. LESOBL(1)='YG1 '
  523. LESOBL(2)='YG2 '
  524. LESOBL(3)='YG3 '
  525. LESOBL(4)='NU12'
  526. LESOBL(5)='NU23'
  527. LESOBL(6)='NU13'
  528. LESOBL(7)='G12 '
  529. LESOBL(8)='G23 '
  530. LESOBL(9)='G13 '
  531. LESOBL(10)='V1X '
  532. LESOBL(11)='V1Y '
  533. LESOBL(12)='V1Z '
  534. LESOBL(13)='V2X '
  535. LESOBL(14)='V2Y '
  536. LESOBL(15)='V2Z '
  537. ELSE IF (IDIM.EQ.2) THEN
  538. IF(IFOUR.EQ.-2) THEN
  539. C cont. plane
  540. NBROBL=9
  541. NBRFAC=0
  542. SEGINI NOMID
  543. LESOBL(1)='YG1 '
  544. LESOBL(2)='YG2 '
  545. LESOBL(3)='NU12 '
  546. LESOBL(4)='G12'
  547. LESOBL(5)='V1X '
  548. LESOBL(6)='V1Y '
  549. LESOBL(7)='YG3 '
  550. LESOBL(8)='NU23'
  551. LESOBL(9)='NU13'
  552. ELSE IF (IFOUR.EQ.-1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.-3)
  553. $ THEN
  554. C deformation plane ,axisymetrie
  555. NBROBL=9
  556. NBRFAC=0
  557. SEGINI NOMID
  558. LESOBL(1)='YG1 '
  559. LESOBL(2)='YG2 '
  560. LESOBL(3)='YG3 '
  561. LESOBL(4)='NU12'
  562. LESOBL(5)='NU23'
  563. LESOBL(6)='NU13'
  564. LESOBL(7)='G12 '
  565. LESOBL(8)='V1X '
  566. LESOBL(9)='V1Y '
  567. ELSE IF (IFOUR.EQ.1) THEN
  568. C axisymetrie de fourier
  569. NBROBL=11
  570. NBRFAC=0
  571. SEGINI NOMID
  572. LESOBL(1)='YG1 '
  573. LESOBL(2)='YG2 '
  574. LESOBL(3)='YG3 '
  575. LESOBL(4)='NU12'
  576. LESOBL(5)='NU23'
  577. LESOBL(6)='NU13'
  578. LESOBL(7)='G12 '
  579. LESOBL(8)='G23 '
  580. LESOBL(9)='G13 '
  581. LESOBL(10)='V1X '
  582. LESOBL(11)='V1Y '
  583. ENDIF
  584. ELSE IF (IDIM.EQ.1) THEN
  585. NBROBL=6
  586. NBRFAC=0
  587. SEGINI,NOMID
  588. LESOBL(1)='YG1 '
  589. LESOBL(2)='YG2 '
  590. LESOBL(3)='YG3 '
  591. LESOBL(4)='NU12'
  592. LESOBL(5)='NU23'
  593. LESOBL(6)='NU13'
  594. ENDIF
  595. ELSE IF (MFR.EQ.35) THEN
  596. C elements joints
  597. IF (IFOUR.EQ.2) THEN
  598. NBROBL=5
  599. NBRFAC=0
  600. SEGINI NOMID
  601. LESOBL(1)='KS1 '
  602. LESOBL(2)='KS2 '
  603. LESOBL(3)='KN '
  604. LESOBL(4)='V1X '
  605. LESOBL(5)='V1Y '
  606. ENDIF
  607. ENDIF
  608. C* ELSEIF (CMATE.EQ.'ANISOTRO') THEN
  609. ELSEIF (MATE.EQ.3) THEN
  610. C
  611. IF(MFR.EQ.75)THEN
  612. C
  613. C JOINT UNIDIMESIONNEL JOI1
  614. C
  615. IF(IDIM.EQ.3)THEN
  616. NBROBL=27
  617. NBRFAC=0
  618. SEGINI NOMID
  619. LESOBL(1)='V1X '
  620. LESOBL(2)='V1Y '
  621. LESOBL(3)='V1Z '
  622. LESOBL(4)='V2X '
  623. LESOBL(5)='V2Y '
  624. LESOBL(6)='V2Z '
  625. LESOBL(7)='D11 '
  626. LESOBL(8)='D22 '
  627. LESOBL(9)='D33 '
  628. LESOBL(10)='D44 '
  629. LESOBL(11)='D55 '
  630. LESOBL(12)='D66 '
  631. LESOBL(13)='D21 '
  632. LESOBL(14)='D31 '
  633. LESOBL(15)='D32 '
  634. LESOBL(16)='D41 '
  635. LESOBL(17)='D42 '
  636. LESOBL(18)='D43 '
  637. LESOBL(19)='D51 '
  638. LESOBL(20)='D52 '
  639. LESOBL(21)='D53 '
  640. LESOBL(22)='D54 '
  641. LESOBL(23)='D61 '
  642. LESOBL(24)='D62 '
  643. LESOBL(25)='D63 '
  644. LESOBL(26)='D64 '
  645. LESOBL(27)='D65 '
  646. ELSE IF(IDIM.EQ.2)THEN
  647. NBROBL=8
  648. NBRFAC=0
  649. SEGINI NOMID
  650. LESOBL(1)='V1X '
  651. LESOBL(2)='V1Y '
  652. LESOBL(3)='D11 '
  653. LESOBL(4)='D22 '
  654. LESOBL(5)='D33 '
  655. LESOBL(6)='D21 '
  656. LESOBL(7)='D31 '
  657. LESOBL(8)='D32 '
  658. ENDIF
  659. C
  660. ELSE IF (MFR.EQ.1.OR.MFR.EQ.31) THEN
  661. C elements massifs
  662. IF(IDIM.EQ.3)THEN
  663. C elements 3d
  664. IF (IFOUR.EQ.2) THEN
  665. NBROBL=27
  666. NBRFAC=0
  667. SEGINI NOMID
  668. LESOBL(1)='D11 '
  669. LESOBL(2)='D21 '
  670. LESOBL(3)='D22 '
  671. LESOBL(4)='D31 '
  672. LESOBL(5)='D32 '
  673. LESOBL(6)='D33 '
  674. LESOBL(7)='D41 '
  675. LESOBL(8)='D42 '
  676. LESOBL(9)='D43 '
  677. LESOBL(10)='D44 '
  678. LESOBL(11)='D51 '
  679. LESOBL(12)='D52 '
  680. LESOBL(13)='D53 '
  681. LESOBL(14)='D54 '
  682. LESOBL(15)='D55 '
  683. LESOBL(16)='D61 '
  684. LESOBL(17)='D62 '
  685. LESOBL(18)='D63 '
  686. LESOBL(19)='D64 '
  687. LESOBL(20)='D65 '
  688. LESOBL(21)='D66 '
  689. LESOBL(22)='V1X '
  690. LESOBL(23)='V1Y '
  691. LESOBL(24)='V1Z '
  692. LESOBL(25)='V2X '
  693. LESOBL(26)='V2Y '
  694. LESOBL(27)='V2Z '
  695. ENDIF
  696. ELSE IF (IDIM.EQ.2) THEN
  697. IF (IFOUR.EQ.-2) THEN
  698. C contrainte plane
  699. NBROBL=12
  700. NBRFAC=0
  701. C*OF A VOIR !!!! NBROBL=8
  702. C*OF A VOIR !!!! NBRFAC=4
  703. SEGINI NOMID
  704. LESOBL(1)='D11 '
  705. LESOBL(2)='D21 '
  706. LESOBL(3)='D22 '
  707. LESOBL(4)='D41 '
  708. LESOBL(5)='D42 '
  709. LESOBL(6)='D44 '
  710. LESOBL(7)='V1X '
  711. LESOBL(8)='V1Y '
  712. LESOBL(9)='D31 '
  713. LESOBL(10)='D32 '
  714. LESOBL(11)='D33 '
  715. LESOBL(12)='D43 '
  716. ELSE IF (IFOUR.EQ.-1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.-3)
  717. $ THEN
  718. C deformation plane ,axisymetrie
  719. NBROBL=12
  720. NBRFAC=0
  721. SEGINI NOMID
  722. LESOBL(1)='D11 '
  723. LESOBL(2)='D21 '
  724. LESOBL(3)='D22 '
  725. LESOBL(4)='D31 '
  726. LESOBL(5)='D32 '
  727. LESOBL(6)='D33 '
  728. LESOBL(7)='D41 '
  729. LESOBL(8)='D42 '
  730. LESOBL(9)='D43 '
  731. LESOBL(10)='D44 '
  732. LESOBL(11)='V1X '
  733. LESOBL(12)='V1Y '
  734. ELSE IF (IFOUR.EQ.1) THEN
  735. C axisymetrie de fourier
  736. NBROBL=15
  737. NBRFAC=0
  738. SEGINI NOMID
  739. LESOBL(1)='D11 '
  740. LESOBL(2)='D21 '
  741. LESOBL(3)='D22 '
  742. LESOBL(4)='D31 '
  743. LESOBL(5)='D32 '
  744. LESOBL(6)='D33 '
  745. LESOBL(7)='D41 '
  746. LESOBL(8)='D42 '
  747. LESOBL(9)='D43 '
  748. LESOBL(10)='D44 '
  749. LESOBL(11)='D55 '
  750. LESOBL(12)='D65 '
  751. LESOBL(13)='D66 '
  752. LESOBL(14)='V1X '
  753. LESOBL(15)='V1Y '
  754. ENDIF
  755. ENDIF
  756. ENDIF
  757. C* ELSEIF (CMATE.EQ.'UNIDIREC') THEN
  758. ELSEIF (MATE.EQ.4) THEN
  759. IF ((MFR.EQ.1.OR.MFR.EQ.31).AND.IDIM.EQ.3) THEN
  760. NBROBL=7
  761. NBRFAC=0
  762. SEGINI NOMID
  763. LESOBL(1)='YOUN'
  764. LESOBL(2)='V1X '
  765. LESOBL(3)='V1Y '
  766. LESOBL(4)='V1Z '
  767. LESOBL(5)='V2X '
  768. LESOBL(6)='V2Y '
  769. LESOBL(7)='V2Z '
  770. ELSE
  771. NBROBL=3
  772. NBRFAC=0
  773. SEGINI NOMID
  774. MOMATR=NOMID
  775. LESOBL(1)='YOUN'
  776. LESOBL(2)='V1X '
  777. LESOBL(3)='V1Y '
  778. ENDIF
  779.  
  780. C* ELSEIF (CMATE.EQ.'ZONE_COH') THEN
  781. ELSEIF (MATE.EQ.12) THEN
  782. NBROBL=0
  783. NBRFAC=0
  784. IF (MFR.EQ.77) THEN
  785. NBROBL=2
  786. SEGINI NOMID
  787. MOMATR=NOMID
  788. LESOBL(1)='KS '
  789. LESOBL(2)='KN '
  790. ENDIF
  791. C
  792. ELSE
  793. if(lnomid(6).ne.0) then
  794. nomid=lnomid(6)
  795. nbrobl=lesobl(/2)
  796. nbrfac=lesfac(/2)
  797. lsupma=.false.
  798. else
  799. CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  800. nomid=momatr
  801. endif
  802. ENDIF
  803. ELSE
  804. if(lnomid(6).ne.0) then
  805. nomid=lnomid(6)
  806. nbrobl=lesobl(/2)
  807. nbrfac=lesfac(/2)
  808. lsupma=.false.
  809. else
  810. CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  811. nomid=momatr
  812. endif
  813. ENDIF
  814. MOMATR=NOMID
  815. NMATR=NBROBL
  816. NMATF=NBRFAC
  817. NMATT=NMATR+NMATF
  818. C
  819. IF (MOMATR.EQ.0) THEN
  820. CALL ERREUR(5)
  821. GOTO 9990
  822. ENDIF
  823.  
  824. C* IF (CMATE.EQ.'SECTION') THEN
  825. IF (MATE.EQ.11) THEN
  826. NBTYPE=3
  827. SEGINI NOTYPE
  828. TYPE(1)='POINTEURMMODEL'
  829. TYPE(2)='POINTEURMCHAML'
  830. TYPE(3)='POINTEURLISTREEL'
  831. ELSE
  832. NBTYPE=1
  833. SEGINI NOTYPE
  834. TYPE(1)='REAL*8'
  835. ENDIF
  836. MOTYPE=NOTYPE
  837. C
  838. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  839. SEGSUP NOTYPE
  840. IF (IERR.NE.0) THEN
  841. ISUP2 = 0
  842. GOTO 9990
  843. ENDIF
  844. C
  845. IF(ISUP2.EQ.1)THEN
  846. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  847. ENDIF
  848. C
  849. C traitement des champs caracteristiques
  850. C
  851. NOMID =0
  852. NBROBL=0
  853. NBRFAC=0
  854. C
  855. C epaisseur et excentrement dans le cas des coques
  856. C
  857. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  858. NBROBL=1
  859. NBRFAC=1
  860. SEGINI NOMID
  861. LESOBL(1)='EPAI'
  862. LESFAC(1)='EXCE'
  863. C
  864. C section pour les barres
  865. C
  866. ELSE IF (MFR.EQ.27) THEN
  867. NBROBL=1
  868. SEGINI NOMID
  869. LESOBL(1)='SECT'
  870. C
  871. C section, excentrements et orientation pour les barres excentrees
  872. C
  873. ELSE IF (MFR.EQ.49) THEN
  874. NBROBL=6
  875. SEGINI NOMID
  876. LESOBL(1)='SECT'
  877. LESOBL(2)='EXCZ'
  878. LESOBL(3)='EXCY'
  879. LESOBL(4)='VX '
  880. LESOBL(5)='VY '
  881. LESOBL(6)='VZ '
  882. C
  883. C raideurs locales et orientation pour l'element LIA2
  884. C de liaison a 2 noeuds
  885. C
  886. ELSE IF (MFR.EQ.51) THEN
  887. NBROBL=9
  888. SEGINI NOMID
  889. LESOBL(1)='RLUX'
  890. LESOBL(2)='RLUY'
  891. LESOBL(3)='RLUZ'
  892. LESOBL(4)='RLRX'
  893. LESOBL(5)='RLRY'
  894. LESOBL(6)='RLRZ'
  895. LESOBL(7)='VX '
  896. LESOBL(8)='VY '
  897. LESOBL(9)='VZ '
  898. C
  899. C caracteristiques pour les poutres
  900. C
  901. ELSE IF (MFR.EQ.7 ) THEN
  902. C* IF (CMATE.NE.'SECTION') THEN
  903. IF (MATE.NE.11) THEN
  904. C
  905. C CAS 2D
  906. C
  907. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  908. NBRFAC=1
  909. NBROBL=2
  910. SEGINI NOMID
  911. LESOBL(1)= 'SECT'
  912. LESOBL(2)= 'INRZ'
  913. LESFAC(1)= 'SECY'
  914. C
  915. ELSE
  916. NBROBL=4
  917. NBRFAC=2
  918. SEGINI NOMID
  919. LESOBL(1)='TORS'
  920. LESOBL(2)='INRY'
  921. LESOBL(3)='INRZ'
  922. LESOBL(4)='SECT'
  923. LESFAC(1)='SECY'
  924. LESFAC(2)='SECZ'
  925. ENDIF
  926. ENDIF
  927. C
  928. C caracteristiques pour les tuyaux
  929. C
  930. ELSE IF (MFR.EQ.13) THEN
  931. NBROBL=2
  932. NBRFAC=3
  933. SEGINI NOMID
  934. LESOBL(1)='EPAI'
  935. LESOBL(2)='RAYO'
  936. LESFAC(1)='RACO'
  937. LESFAC(2)='PRES'
  938. LESFAC(3)='CISA'
  939. C
  940. C caracteristiques pour les linespring
  941. C
  942. ELSE IF (MFR.EQ.15) THEN
  943. NBROBL=5
  944. SEGINI NOMID
  945. LESOBL(1)='EPAI'
  946. LESOBL(2)='FISS'
  947. LESOBL(3)='VX '
  948. LESOBL(4)='VY '
  949. LESOBL(5)='VZ '
  950. C
  951. C caracteristiques pour les tuyaux fissures
  952. C
  953. ELSE IF (MFR.EQ.17) THEN
  954. NBROBL=9
  955. SEGINI NOMID
  956. LESOBL(1)='RAYO'
  957. LESOBL(2)='EPAI'
  958. LESOBL(3)='VX '
  959. LESOBL(4)='VY '
  960. LESOBL(5)='VZ '
  961. LESOBL(6)='VXF '
  962. LESOBL(7)='VYF '
  963. LESOBL(8)='VZF '
  964. LESOBL(9)='ANGL'
  965. C
  966. C caracteristiques des elements homogeneises
  967. C
  968. ELSE IF (MFR.EQ.37) THEN
  969. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  970. NBROBL=4
  971. SEGINI NOMID
  972. LESOBL(1)='SCEL'
  973. LESOBL(2)='SFLU'
  974. LESOBL(3)='EPS '
  975. LESOBL(4)='XINE'
  976. ELSE
  977. NBROBL=3
  978. SEGINI NOMID
  979. LESOBL(1)='SCEL'
  980. LESOBL(2)='SFLU'
  981. LESOBL(3)='EPS '
  982. ENDIF
  983. ENDIF
  984. MOCARA=NOMID
  985. NCARA=NBROBL
  986. NCARF=NBRFAC
  987. ncarr= NCARA+NCARF
  988. NCARRw=NCARA+NCARF
  989. if( MFR.EQ.13) ncarrw=ncarrw + 10
  990. IF (MOCARA.NE.0) THEN
  991. NBTYPE=1
  992. SEGINI NOTYPE
  993. TYPE(1)='REAL*8'
  994. MOTYPE=NOTYPE
  995. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3
  996. $ ,IVACAR)
  997. SEGSUP NOTYPE
  998. IF (IERR.NE.0) THEN
  999. ISUP2 = 0
  1000. GOTO 9990
  1001. ENDIF
  1002. IF (ISUP2.EQ.1) THEN
  1003. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  1004. ENDIF
  1005. ENDIF
  1006. C
  1007. c____________________________________________________________________
  1008. c
  1009. C traitement des champs de variables internes *
  1010. c____________________________________________________________________
  1011. c
  1012. IF(INAT.EQ.62.AND .IPCHE3.EQ.0) NVART = 3
  1013. IF(INAT.EQ.30.AND .IPCHE3.EQ.0) NVART = 2
  1014. IF (IPCHE3.NE.0) THEN
  1015. if(lnomid(10).ne.0) then
  1016. nomid=lnomid(10)
  1017. movari=nomid
  1018. nvari=lesobl(/2)
  1019. nvarf=lesfac(/2)
  1020. lsupva=.false.
  1021. else
  1022. CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF)
  1023. lsupva=.true.
  1024. endif
  1025. IF (MOVARI.EQ.0) THEN
  1026. MOTERR(1:4)='VARI'
  1027. MOTERR(5:8)=NOMTP(MELE)
  1028. CALL ERREUR(76)
  1029. GOTO 9990
  1030. ENDIF
  1031. NVART=NVARI+NVARF
  1032. C
  1033. NBTYPE=1
  1034. SEGINI NOTYPE
  1035. TYPE(1)='REAL*8'
  1036. MOTYPE=NOTYPE
  1037. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOVARI,MOTYPE,1,
  1038. 1 INFOS,3,IVARI)
  1039. SEGSUP NOTYPE
  1040. IF (IERR.NE.0) THEN
  1041. ISUP3 = 0
  1042. GOTO 9990
  1043. ENDIF
  1044. C
  1045. IF (ISUP3.EQ.1) THEN
  1046. CALL VALCHE(IVARI,NVART,IPMIN1,IPPORE,MOVARI,MELE)
  1047. ENDIF
  1048. ENDIF
  1049. c____________________________________________________________________
  1050. C
  1051. C recherche des dimensions qui correspondraient
  1052. C a un MELVAL de HOOKE
  1053. c____________________________________________________________________
  1054. N2PTEL=0
  1055. N2EL=0
  1056. MPTVAL=IVAMAT
  1057. DO 1500 IO=1,NMATT
  1058. MELVAL=IVAL(IO)
  1059. IF(MELVAL.NE.0)THEN
  1060. C* IF (CMATE.EQ.'SECTION') THEN
  1061. IF (MATE.EQ.11) THEN
  1062. N2PTEL=MAX(N2PTEL,IELCHE(/1))
  1063. N2EL =MAX(N2EL ,IELCHE(/2))
  1064. ELSE
  1065. N2PTEL=MAX(N2PTEL,VELCHE(/1))
  1066. N2EL =MAX(N2EL ,VELCHE(/2))
  1067. ENDIF
  1068. ENDIF
  1069. 1500 CONTINUE
  1070. MPTVAL=IVACAR
  1071. DO 41 IO=1,NCARR
  1072. MELVAL=IVAL(IO)
  1073. IF(MELVAL.NE.0)THEN
  1074. C* IF (CMATE.EQ.'SECTION') THEN
  1075. IF (MATE.EQ.11) THEN
  1076. N2PTEL=MAX(N2PTEL,IELCHE(/1))
  1077. N2EL =MAX(N2EL ,IELCHE(/2))
  1078. ELSE
  1079. N2PTEL=MAX(N2PTEL,VELCHE(/1))
  1080. N2EL =MAX(N2EL ,VELCHE(/2))
  1081. ENDIF
  1082. ENDIF
  1083. 41 CONTINUE
  1084. IF (IPCHE3.NE.0) THEN
  1085. MPTVAL=IVARI
  1086. DO 42 IO=1,NVART
  1087. MELVAL=IVAL(IO)
  1088. IF(MELVAL.NE.0)THEN
  1089. C* IF (CMATE.EQ.'SECTION') THEN
  1090. IF (MATE.EQ.11) THEN
  1091. N2PTEL=MAX(N2PTEL,IELCHE(/1))
  1092. N2EL =MAX(N2EL ,IELCHE(/2))
  1093. ELSE
  1094. N2PTEL=MAX(N2PTEL,VELCHE(/1))
  1095. N2EL =MAX(N2EL ,VELCHE(/2))
  1096. ENDIF
  1097. ENDIF
  1098. 42 CONTINUE
  1099. ENDIF
  1100. IF (N2PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  1101. N2PTEL=1
  1102. ELSE
  1103. N2PTEL=NBPGAU
  1104. ENDIF
  1105. C
  1106. C INITIALISATION DES TABLEAUX DE TRAVAIL
  1107. C
  1108. NMAT1=NMATT
  1109. C cette sequence est presente car la troisieme composante
  1110. C (eventuellement) obligatoire est la septieme composante du materiau
  1111. IF(INAT.EQ.26) NMATT=NMATT+4
  1112. SEGINI IWRK1
  1113. IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) SEGINI IWRK4
  1114. C
  1115. IF(MFR.EQ.15) THEN
  1116. IF(NBPGAU.EQ.1) THEN
  1117. S(1)= REAL(0.D0)
  1118. ELSE IF(NBPGAU.EQ.3) THEN
  1119. S(1)=-X774
  1120. S(2)= REAL(0.D0)
  1121. S(3)= X774
  1122. ENDIF
  1123. ENDIF
  1124. C
  1125. IWRK2 = 0
  1126. C* IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  1127. C* & CMATE.EQ.'UNIDIREC') .OR.
  1128. IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .OR.
  1129. & ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2)) THEN
  1130. SEGINI IWRK2
  1131. ENDIF
  1132. C
  1133. C traitement special pour milieu non isotrope
  1134. C
  1135. IPMIN2 = 0
  1136. IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN
  1137. C* IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  1138. C* & CMATE.EQ.'UNIDIREC') THEN
  1139. IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  1140. IELE=NUMGEO(MELE)
  1141. CALL RESHPT(1,NBNO,IELE,MELE,NPINT,IPMIN2,IRT1)
  1142. MINTE2=IPMIN2
  1143. ENDIF
  1144. ENDIF
  1145. C
  1146. C boucle sur les elements
  1147. C
  1148. DO 2000 IB=1,NBELEM
  1149. C
  1150. C
  1151. IF (IWRK2.NE.0) THEN
  1152. C* IF ( ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  1153. C* & CMATE.EQ.'UNIDIREC').AND.
  1154. C** IF ( ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .OR.
  1155. C* & (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33)) .OR.
  1156. C* & ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2) ) THEN
  1157.  
  1158. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1159. C
  1160. IF (IPMIN2.NE.0) THEN
  1161. C* IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN
  1162. C
  1163. C traitement special pour milieu non isotrope
  1164. C
  1165. NBSH=MINTE2.SHPTOT(/2)
  1166. CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  1167. if (nbsh.eq.-1) then
  1168. call erreur(525)
  1169. return
  1170. endif
  1171. ENDIF
  1172. ENDIF
  1173. C
  1174. C boucle sur les points de gauss
  1175. C
  1176. DO 3000 IGAU=1,NBPTEL
  1177.  
  1178. IRECAL=1
  1179. C
  1180. C si N2PTEL et N2EL sont egaux a 1 => champ uniforme dans le maillage
  1181. C => on ne calcule qu'une fois la matrice de HOOKE
  1182. C
  1183. IF(N2PTEL.EQ.1.AND.N2EL.EQ.1) THEN
  1184. IF(IB.GT.1.OR.IGAU.GT.1) THEN
  1185. IRECAL=0
  1186. ENDIF
  1187. ENDIF
  1188. C
  1189. C si N2PTEL est egal a 1 mais pas N2EL => champ uniforme dans l'element
  1190. C => on ne calcule qu'une fois la matrice de HOOKE par element
  1191. C
  1192. IF(N2PTEL.EQ.1.AND.N2EL.NE.1) THEN
  1193. IF(IGAU.GT.1) THEN
  1194. IRECAL=0
  1195. ENDIF
  1196. ENDIF
  1197. c
  1198. c sinon on RECALCULE ( EXTRAIT DE HOOK2D )
  1199. c
  1200. IF(IRECAL.EQ.1) THEN
  1201. C
  1202. MPTVAL=IVAMAT
  1203. DO 1005 IM=1,NMAT1
  1204. MELVAL=IVAL(IM)
  1205. IF (MELVAL.NE.0) THEN
  1206. IF (TYVAL(IM).EQ.'REAL*8') THEN
  1207. IBMN=MIN(IB ,VELCHE(/2))
  1208. IGMN=MIN(IGAU,VELCHE(/1))
  1209. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1210. ELSE
  1211. IBMN=MIN(IB ,IELCHE(/2))
  1212. IGMN=MIN(IGAU,IELCHE(/1))
  1213. VALMAT(IM)=IELCHE(IGMN,IBMN)
  1214. ENDIF
  1215. ELSE
  1216. VALMAT(IM)=0.D0
  1217. ENDIF
  1218. 1005 CONTINUE
  1219. C
  1220. C cette sequence est presente car la troisieme composante
  1221. C (eventuellement) obligatoire est la septieme composante du materiau
  1222. IF(INAT.EQ.26) THEN
  1223. VALMAT(7)=VALMAT(3)
  1224. DO 1006 ICOMP=3,6
  1225. VALMAT(ICOMP)=REAL(0.D0)
  1226. 1006 CONTINUE
  1227. ENDIF
  1228. C
  1229. IF(INAT.EQ.26.OR.INAT.EQ.29.OR.INAT.EQ.30.OR.
  1230. . INAT.EQ.62.OR.INAT.EQ.64.OR.INAT.EQ.65.OR.INAT.EQ.118) THEN
  1231. MPTVAL=IVARI
  1232. DO 1007 IM=1,NVART
  1233. IF (IVAL(IM).NE.0) THEN
  1234. MELVAL=IVAL(IM)
  1235. IBMN=MIN(IB ,VELCHE(/2))
  1236. IGMN=MIN(IGAU,VELCHE(/1))
  1237. VAR(IM)=VELCHE(IGMN,IBMN)
  1238. ELSE
  1239. VAR(IM)=0.D0
  1240. ENDIF
  1241. 1007 CONTINUE
  1242. ENDIF
  1243. C
  1244. IF(MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.15.
  1245. 1 OR.MFR.EQ.17) THEN
  1246. C
  1247. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  1248. C
  1249. C* IF(CMATE.EQ.'SECTION') THEN
  1250. IF(MATE.EQ.11) THEN
  1251. C
  1252. MPTVAL=IVAMAT
  1253. MELVAL=IVAL(1)
  1254. IBMN=MIN(IB ,IELCHE(/2))
  1255. IGMN=MIN(IGAU,IELCHE(/1))
  1256. IPMODS=IELCHE(IGMN,IBMN)
  1257. MELVAL=IVAL(2)
  1258. IBMN=MIN(IB ,IELCHE(/2))
  1259. IGMN=MIN(IGAU,IELCHE(/1))
  1260. IPCAS=IELCHE(IGMN,IBMN)
  1261. CALL FRIGIE(IPMODS,IPCAS,CRIGI,CMASS)
  1262. C
  1263. ELSEIF (MFR.EQ.15) THEN
  1264. C
  1265. IE=1
  1266. MPTVAL=IVACAR
  1267. DO 7030 IC=1,3,2
  1268. DO 7029 ICOMP=1,NCARR
  1269. MELVAL=IVAL(ICOMP)
  1270. IF (MELVAL.NE.0) THEN
  1271. IGMN=MIN(IC,VELCHE(/1))
  1272. IBMN=MIN(IB,VELCHE(/2))
  1273. VALCAR(IE)=VELCHE(IGMN,IBMN)
  1274. ELSE
  1275. VALCAR(IE)=REAL(0.D0)
  1276. ENDIF
  1277. IE=IE+1
  1278. 7029 CONTINUE
  1279. 7030 CONTINUE
  1280. C
  1281. ELSE
  1282. C
  1283. MPTVAL=IVACAR
  1284. DO 1010 ICOMP=1,NCARR
  1285. MELVAL=IVAL(ICOMP)
  1286. IF (MELVAL.NE.0) THEN
  1287. IBMN=MIN(IB ,VELCHE(/2))
  1288. IGMN=MIN(IGAU,VELCHE(/1))
  1289. VALCAR(ICOMP)=VELCHE(IGMN,IBMN)
  1290. ELSE
  1291. VALCAR(ICOMP)=REAL(0.D0)
  1292. ENDIF
  1293. 1010 CONTINUE
  1294. ENDIF
  1295. ENDIF
  1296. C
  1297. IF(MFR.EQ.27.OR.MFR.EQ.49) THEN
  1298. C
  1299. C ON CHERCHE LA SECTION DE L'ELEMENT IB
  1300. C
  1301. MPTVAL=IVACAR
  1302. MELVAL=IVAL(1)
  1303. IF (MELVAL.NE.0) THEN
  1304. IBMN=MIN(IB ,VELCHE(/2))
  1305. IGMN=MIN(IGAU,VELCHE(/1))
  1306. SECT=VELCHE(IGMN,IBMN)
  1307. ELSE
  1308. SECT=REAL(0.D0)
  1309. ENDIF
  1310. ENDIF
  1311. C
  1312. C Prise en compte de l'epaisseur et de l'excentrement
  1313. C dans le cas des coques minces avec ou sans cisaillement
  1314. C transverse
  1315. C
  1316. IF (MFR.EQ.3.OR.MFR.EQ.9) THEN
  1317. C* IF (CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ORTHOTRO'.OR.
  1318. C* 1 CMATE.EQ.'UNIDIREC') THEN
  1319. IF (MATE.EQ.1.OR.MATE.EQ.2.OR.MATE.EQ.4) THEN
  1320. MPTVAL=IVACAR
  1321. MELVAL=IVAL(1)
  1322. IF (MELVAL.NE.0) THEN
  1323. IBMN=MIN(IB ,VELCHE(/2))
  1324. IGMN=MIN(IGAU,VELCHE(/1))
  1325. EPAIST=VELCHE(IGMN,IBMN)
  1326. ELSE
  1327. CALL ERREUR(527)
  1328. GOTO 9990
  1329. ENDIF
  1330. C
  1331. C LASURF=0
  1332. EXCEN = REAL(0.D0)
  1333. ENDIF
  1334. ENDIF
  1335.  
  1336. C ______________________________________________________________________
  1337. C
  1338. C TRAITEMENT SUIVANT TYPE DE MATERIAU
  1339. C_______________________________________________________________________
  1340. IRETOU = 1
  1341. C* IF (CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ZONE_COH') THEN
  1342. IF (MATE.EQ.1.OR.MATE.EQ.12) THEN
  1343. CALL HOOKIS(VALMAT,VALCAR,VAR,MFR,IB,IGAU,EXCEN,EPAIST,
  1344. + INAT,MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL,
  1345. + S,SECT,LHOOK,DDHOMU,DDHOOK,
  1346. + COBMA,XMOB,IRETOU)
  1347. C
  1348. C* ELSE IF (CMATE.EQ.'ORTHOTRO') THEN
  1349. ELSE IF (MATE.EQ.2) THEN
  1350. CALL HOOKOR(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST,
  1351. + MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL,SECT,LHOOK,
  1352. + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK,
  1353. + COBMA,XMOB,IRETOU)
  1354. C
  1355. C* ELSE IF (CMATE.EQ.'ANISOTRO') THEN
  1356. ELSE IF (MATE.EQ.3) THEN
  1357. CALL HOOKAN(VALMAT,IB,IGAU,MFR,IFOUR,KCAS,N2PTEL,N2EL,
  1358. + SECT,LHOOK,TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOOK,
  1359. + MELE,COBMA,XMOB,IRETOU)
  1360. C
  1361. C* ELSE IF (CMATE.EQ.'UNIDIREC') THEN
  1362. ELSE IF (MATE.EQ.4) THEN
  1363. CALL HOOKUN(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST,
  1364. + MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL,SECT,LHOOK,
  1365. + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK,
  1366. + COBMA,XMOB,IRETOU)
  1367. C
  1368. ELSE IF (CMATE.EQ.'HOMOGENE') THEN
  1369. C* ELSE IF (MATE.EQ.9) THEN
  1370. CALL HOOKHO(VALMAT,IB,IGAU,MFR,N2PTEL,N2EL,SECT,
  1371. + LHOOK,DDHOOK,IRETOU)
  1372. C
  1373. C* ELSE IF (CMATE.EQ.'SECTION') THEN
  1374. ELSE IF (MATE.EQ.11) THEN
  1375. CALL HOOKSE(VALMAT,IB,IGAU,MFR,CRIGI,IFOUR,
  1376. + N2PTEL,N2EL,SECT,LHOOK,DDHOOK,IRETOU)
  1377. C
  1378. ENDIF
  1379. C
  1380. IF (IRETOU.EQ.0) THEN
  1381. IF (MFR.EQ.3.AND.NPINT.NE.0) THEN
  1382. CALL ERREUR(251)
  1383. ELSE
  1384. MOTERR(1:8)=NOMFR(MFR/2+1)
  1385. CALL ERREUR(193)
  1386. ENDIF
  1387. GOTO 2000
  1388. ENDIF
  1389. C
  1390. C inversion si besoin
  1391. C
  1392. IF(KCAS.EQ.2.AND.INAT.NE.26.AND.INAT.NE.29.
  1393. & AND.INAT.NE.65) THEN
  1394. CALL INVALM(DDHOOK,LHOOK,LHOOK,KERRE,0.D0)
  1395. IF(KERRE.NE.0) THEN
  1396. CALL ERREUR(713)
  1397. GO TO 9992
  1398. ENDIF
  1399. ENDIF
  1400. C
  1401. C fin du test irecal
  1402. ENDIF
  1403. C
  1404. C ------ fin de determination de la matrice de hooke
  1405. C
  1406. C
  1407. C on remplit ici les differentes quantites necessaires
  1408. C
  1409. C deformations
  1410. C
  1411. MPTVAL=IVASTR
  1412. IF (KCAS.EQ.2) THEN
  1413. DO 4000 ICOMP=1,NSTR
  1414. MELVAL=IVAL(ICOMP)
  1415. IGMN=MIN(IGAU,VELCHE(/1))
  1416. IBMN=MIN(IB ,VELCHE(/2))
  1417. SIGF(ICOMP)=VELCHE(IGMN,IBMN)
  1418. 4000 CONTINUE
  1419. C* ELSE IF(KCAS.EQ.1) THEN
  1420. ELSE
  1421. DO 4001 ICOMP=1,NSTR
  1422. MELVAL=IVAL(ICOMP)
  1423. IGMN=MIN(IGAU,VELCHE(/1))
  1424. IBMN=MIN(IB ,VELCHE(/2))
  1425. EPSI(ICOMP)=VELCHE(IGMN,IBMN)
  1426. 4001 CONTINUE
  1427. ENDIF
  1428. C
  1429. C cas des milieux poreux
  1430. C
  1431. IF(MFR.EQ.33) THEN
  1432. C
  1433. IF(XMOB.EQ.REAL(0.D0)) THEN
  1434. C**** INTERR(1)=IB
  1435. C**** CALL ERREUR(537)
  1436. UNSURM=REAL(0.D0)
  1437. ELSE
  1438. UNSURM=1.D0/XMOB
  1439. ENDIF
  1440. C
  1441. C calcul des contraintes ou des deformations
  1442. C
  1443. IF(KCAS.EQ.1) THEN
  1444. C
  1445. DO 4500 I=1,LHOOK
  1446. SIGF(I)=-COBMA(I)*EPSI(NSTRS)
  1447. DO 45001 J=1,LHOOK
  1448. SIGF(I)=SIGF(I)+DDHOOK(I,J)*EPSI(J)
  1449. 45001 CONTINUE
  1450. 4500 CONTINUE
  1451. C
  1452. SIGF(NSTRS)=EPSI(NSTRS)*UNSURM
  1453. DO 4502 I=1,LHOOK
  1454. SIGF(NSTRS)=SIGF(NSTRS)+COBMA(I)*EPSI(I)
  1455. 4502 CONTINUE
  1456. C
  1457. C
  1458. C* ELSE IF (KCAS.EQ.2) THEN
  1459. ELSE
  1460. C
  1461. CALL ZERO(VECO1,LHOOK,1)
  1462. CALL ZERO(VECO2,LHOOK,1)
  1463. FAC1 = REAL(0.D0)
  1464. FAC2 = REAL(0.D0)
  1465. DO 5003 I=1,LHOOK
  1466. DO 5004 J=1,LHOOK
  1467. VECO1(I)=VECO1(I)+DDHOOK(I,J)*SIGF(J)
  1468. VECO2(I)=VECO2(I)+DDHOOK(I,J)*COBMA(J)
  1469. 5004 CONTINUE
  1470. FAC1 = FAC1 + COBMA(I)*VECO1(I)
  1471. FAC2 = FAC2 + COBMA(I)*VECO2(I)
  1472. 5003 CONTINUE
  1473.  
  1474. EPSI(NSTRS)=(SIGF(NSTRS)-FAC1)/(UNSURM+FAC2)
  1475.  
  1476. DO 5000 I=1,LHOOK
  1477. EPSI(I)=REAL(0.D0)
  1478. DO 50001 J=1,LHOOK
  1479. EPSI(I)=EPSI(I)+DDHOOK(I,J)*
  1480. . (SIGF(J)+ COBMA(J)*EPSI(NSTRS))
  1481. 50001 CONTINUE
  1482. 5000 CONTINUE
  1483. ENDIF
  1484. C
  1485. C autres cas
  1486. C
  1487. ELSE
  1488. C
  1489. IF(KCAS.EQ.1) THEN
  1490. DO 5500 I=1,LHOOK
  1491. SIGF(I)=REAL(0.D0)
  1492. DO 55001 J=1,LHOOK
  1493. SIGF(I)=SIGF(I)+DDHOOK(I,J)*EPSI(J)
  1494. 55001 CONTINUE
  1495. 5500 CONTINUE
  1496. C* ELSE IF (KCAS.EQ.2) THEN
  1497. ELSE
  1498. DO 6000 I=1,LHOOK
  1499. EPSI(I)=REAL(0.D0)
  1500. DO 60001 J=1,LHOOK
  1501. EPSI(I)=EPSI(I)+DDHOOK(I,J)*SIGF(J)
  1502. 60001 CONTINUE
  1503. 6000 CONTINUE
  1504. ENDIF
  1505. C
  1506. C cas des tuyaux fissures
  1507. C
  1508. IF (MFR.EQ.17) THEN
  1509. IF (KCAS.EQ.1) THEN
  1510. C
  1511. MPTVAL=IVAMAT
  1512. MELVAL=IVAL(1)
  1513. IBMN=MIN(IB,VELCHE(/2))
  1514. IGMN=MIN(IGAU,VELCHE(/1))
  1515. YOU=VELCHE(IGMN,IBMN)
  1516. C
  1517. RAYO=VALCAR(1)
  1518. EPAI=VALCAR(2)
  1519. TETA1=VALCAR(9)*UNDEMI
  1520. c conversion de teta1 en radian
  1521. TETA = (TETA1 * XPI)/REAL(180.D0)
  1522. TESPI = TETA/XPI
  1523. c on met dans 'raymo' le rayon moyen du tuyau.
  1524. RAYMO =RAYO - (EPAI/DEUX)
  1525. c calcul de a coefiicient zahor
  1526. RSURT=RAYMO / EPAI
  1527. IF(RSURT.LE.10.D0.AND.RSURT.GE.4.9D0) THEN
  1528. AXX = ( .125D0*RSURT - .25D0 ) **.25D0
  1529. ELSE IF(RSURT.GT.10.D0.AND.RSURT.LE.35.D0) THEN
  1530. AXX = ( .4D0*RSURT - 3.D0 ) **.25D0
  1531. ELSE
  1532. KERRE=4
  1533. ENDIF
  1534. CALL TUFIFP(TESPI,AXX,FP,FM,FMP,FOP,FOM)
  1535. c
  1536. c facteur d intensite des contraintes
  1537. c
  1538. IF(TETA1.LE.(0.5D0))THEN
  1539. SIGF(7)=REAL(0.D0)
  1540. SIGF(8)=REAL(0.D0)
  1541. GOTO 6500
  1542. ENDIF
  1543. SQQ= XPI * RAYMO * TETA
  1544. SQQ= SQRT(SQQ)
  1545. XEX= SQQ * FOP/(DEUX * XPI * RAYMO *EPAI)
  1546. XFL= SQQ * FOM/(XPI * RAYMO * RAYMO *EPAI)
  1547. SIGF(7)=XEX * SIGF(1) - XFL * SIGF(6)
  1548. c
  1549. c calcul des aires de breche note technique dre/stre/lma 85/695
  1550. c
  1551. SIGM=SIGF(1)/( DEUX * XPI * RAYMO * EPAI )
  1552. SIG=SIGF(6)/( XPI * RAYMO * RAYMO * EPAI )
  1553. XIM= XPI * RAYMO * RAYMO * DEUX * TETA * TETA * FP
  1554. $ /YOU
  1555. XIF= XIM * ( .75D0 +(.25D0 * COS ( TETA )))
  1556. SIGF(8)=XIM * SIGM - XIF * SIG
  1557. C
  1558. C* ELSEIF (KCAS.EQ.2) THEN
  1559. ELSE
  1560. EPSI(7)=REAL(0.D0)
  1561. EPSI(8)=REAL(0.D0)
  1562. C
  1563. ENDIF
  1564. ENDIF
  1565. C
  1566. C cas des lisp et lism
  1567. C
  1568. IF (MFR.EQ.15.AND.KCAS.EQ.1) THEN
  1569. EPA1=VALCAR(1)
  1570. EPA2=VALCAR(6)
  1571. FISS1=VALCAR(2)
  1572. FISS2=VALCAR(7)
  1573. FISS1 = (FISS1*(UNDEMI +UNDEMI/X774))+
  1574. + (FISS2*(UNDEMI-UNDEMI/X774))
  1575. FISS2 = (FISS1*(UNDEMI -UNDEMI/X774))+
  1576. + (FISS2*(UNDEMI+UNDEMI/X774))
  1577. W=(EPA1+EPA2)*UNDEMI
  1578. H1=UNDEMI-UNDEMI*S(IGAU)
  1579. H2=UNDEMI+UNDEMI*S(IGAU)
  1580. A= H1*FISS1+H2*FISS2
  1581. ASURW=(H1*FISS1+H2*FISS2)/W
  1582. CALL LISPFI(ASURW,FM,FF)
  1583. X1=SIGF(1)/W
  1584. X4=SIGF(4)*SIX/(W*W)
  1585. XXX=XPI*A
  1586. XXX=SQRT(XXX)
  1587. XKIE=(X1*FM+X4*FF)*XXX
  1588. SIGF(6)= XKIE
  1589. C
  1590. ENDIF
  1591. ENDIF
  1592. C
  1593. 6500 CONTINUE
  1594.  
  1595. IF(KERRE.EQ.0) THEN
  1596. c
  1597. c remplissage du segment contenant les contraintes a la fin
  1598. c
  1599. MPTVAL=IVARES
  1600. IF (KCAS.EQ.2) THEN
  1601. DO 7000 ICOMP=1,NRES
  1602. MELVA1=IVAL(ICOMP)
  1603. MELVA1.VELCHE(IGAU,IB)=EPSI(ICOMP)
  1604. 7000 CONTINUE
  1605. C* ELSE IF (KCAS.EQ.1) THEN
  1606. ELSE
  1607. DO 7001 ICOMP=1,NRES
  1608. MELVA1=IVAL(ICOMP)
  1609. MELVA1.VELCHE(IGAU,IB)=SIGF(ICOMP)
  1610. 7001 CONTINUE
  1611. ENDIF
  1612. ELSE
  1613. C
  1614. C impression de quelques messages d erreurs
  1615. C
  1616. INTERR(1)=IB
  1617. INTERR(2)=IGAU
  1618. MOTERR(1:4)=NOMTP(MELE)
  1619. IF(KERRE.EQ.1) THEN
  1620. CALL ERREUR(301)
  1621. ELSE IF(KERRE.EQ.2) THEN
  1622. CALL ERREUR(300)
  1623. ELSE IF(KERRE.EQ.3) THEN
  1624. MOTERR(1:8)='ELASTI'
  1625. CALL ERREUR(146)
  1626. ELSE IF(KERRE.EQ.4) THEN
  1627. CALL ERREUR(266)
  1628. ELSE IF(KERRE.EQ.49) THEN
  1629. CALL ERREUR(359)
  1630. ENDIF
  1631. SEGSUP IWRK1
  1632. IF (IWRK2.NE.0) SEGSUP IWRK2
  1633. IF(MFR.EQ.33) SEGSUP IWRK4
  1634. GOTO 9990
  1635. ENDIF
  1636. C
  1637. 3000 CONTINUE
  1638. c
  1639. c cas des elements pout : calcul des efforts tranchants
  1640. c
  1641. IF ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2) THEN
  1642. MPTVAL=IVARES
  1643. SEGINI WPOUT
  1644. IGAU=1
  1645. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1646. r_x = XE(1,2) - XE(1,1)
  1647. r_y = XE(2,2) - XE(2,1)
  1648. XL=SQRT(r_x*r_x + r_y*r_y)
  1649. XL=1.D00/XL
  1650. DO 3200 ICOMP=1,NRES
  1651. MELVA1=IVAL(ICOMP)
  1652. SIG1(ICOMP)=MELVA1.VELCHE(IGAU,IB)
  1653. SIG2(ICOMP)=MELVA1.VELCHE(IGAU+1,IB)
  1654. 3200 CONTINUE
  1655. c r_z = (SIG1(1)+SIG2(1))*0.5D0
  1656. c MELVA1=IVAL(1)
  1657. c MELVA1.VELCHE(IGAU,IB)=r_z
  1658. c MELVA1.VELCHE(IGAU+1,IB)=r_z
  1659. r_z = (SIG1(3)-SIG2(3))*XL
  1660. MELVA1=IVAL(2)
  1661. MELVA1.VELCHE(IGAU,IB)=r_z
  1662. MELVA1.VELCHE(IGAU+1,IB)=r_z
  1663. ELSE
  1664. r_x = XE(1,2) - XE(1,1)
  1665. r_y = XE(2,2) - XE(2,1)
  1666. r_z = XE(3,2) - XE(3,1)
  1667. XL=SQRT(r_x*r_x + r_y*r_y + r_z*r_z)
  1668. XL=1.D0/XL
  1669. DO 3202 ICOMP=1,NRES
  1670. MELVA1=IVAL(ICOMP)
  1671. SIG1(ICOMP)=MELVA1.VELCHE(IGAU,IB)
  1672. SIG2(ICOMP)=MELVA1.VELCHE(IGAU+1,IB)
  1673. 3202 CONTINUE
  1674. c r_z = (SIG1(1)+SIG2(1))*0.5D0
  1675. c MELVA1=IVAL(1)
  1676. c MELVA1.VELCHE(IGAU,IB)=r_z
  1677. c MELVA1.VELCHE(IGAU+1,IB)=r_z
  1678. r_z = (SIG1(6)-SIG2(6))*XL
  1679. MELVA1=IVAL(2)
  1680. MELVA1.VELCHE(IGAU,IB)=r_z
  1681. MELVA1.VELCHE(IGAU+1,IB)=r_z
  1682. r_z = (SIG2(5)-SIG1(5))*XL
  1683. MELVA1=IVAL(3)
  1684. MELVA1.VELCHE(IGAU,IB)=r_z
  1685. MELVA1.VELCHE(IGAU+1,IB)=r_z
  1686. ENDIF
  1687. SEGSUP WPOUT
  1688. ENDIF
  1689. c
  1690. 2000 CONTINUE
  1691. C
  1692. SEGSUP IWRK1
  1693. IF (IWRK2.NE.0) SEGSUP IWRK2
  1694. IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) SEGSUP IWRK4
  1695. C
  1696. IF (ISUP2.EQ.1) THEN
  1697. CALL DTMVAL(IVAMAT,3)
  1698. CALL DTMVAL(IVACAR,3)
  1699. ELSE
  1700. CALL DTMVAL(IVAMAT,1)
  1701. CALL DTMVAL(IVACAR,1)
  1702. ENDIF
  1703. C
  1704. IF(IPCHE3.NE.0) THEN
  1705. IF (ISUP3.EQ.1) THEN
  1706. CALL DTMVAL(IVARI,3)
  1707. ELSE
  1708. CALL DTMVAL(IVARI,1)
  1709. ENDIF
  1710. NOMID=MOVARI
  1711. if(lsupva)SEGSUP NOMID
  1712. ENDIF
  1713. C
  1714. IF (ISUP1.EQ.1) THEN
  1715. CALL DTMVAL(IVASTR,3)
  1716. ELSE
  1717. CALL DTMVAL(IVASTR,1)
  1718. ENDIF
  1719. C
  1720. CALL DTMVAL(IVARES,1)
  1721. C
  1722. NOMID=MOMATR
  1723. if(lsupma)SEGSUP NOMID
  1724. NOMID=MOCARA
  1725. IF (MOCARA.NE.0) SEGSUP NOMID
  1726. NOMID=MOSTRS
  1727. if(lsupin)SEGSUP NOMID
  1728. NOMID=MORES
  1729. if(lsupre)SEGSUP NOMID
  1730. IF (IERR.NE.0) GOTO 9992
  1731. C
  1732. 500 CONTINUE
  1733.  
  1734. IRET = 1
  1735. GOTO 9992
  1736. C
  1737. 9990 CONTINUE
  1738. C
  1739. C erreur dans une sous zone, desactivation et retour
  1740. C
  1741. IF (ISUP1.EQ.1) THEN
  1742. CALL DTMVAL(IVASTR,3)
  1743. ELSE
  1744. CALL DTMVAL(IVASTR,1)
  1745. ENDIF
  1746. NOMID=MOSTRS
  1747. if(lsupin)SEGSUP NOMID
  1748.  
  1749. C CB215821 : La suppression de IVARES tel que c'est commenté ci-dessous
  1750. C peut conduire à une GEMAT ERROR plus loin dans le code
  1751. C Sa suppression en cas d'erreur est suspendue
  1752. C IF (IVARES.NE.0) CALL DTMVAL(IVARES,3)
  1753. NOMID=MORES
  1754. if(lsupre)SEGSUP NOMID
  1755.  
  1756. IF (ISUP2.EQ.1) THEN
  1757. CALL DTMVAL(IVAMAT,3)
  1758. CALL DTMVAL(IVACAR,3)
  1759. ELSE
  1760. CALL DTMVAL(IVAMAT,1)
  1761. CALL DTMVAL(IVACAR,1)
  1762. ENDIF
  1763. IF (MOMATR.NE.0) THEN
  1764. NOMID=MOMATR
  1765. if(lsupma)SEGSUP NOMID
  1766. ENDIF
  1767. IF (MOCARA.NE.0) THEN
  1768. NOMID=MOCARA
  1769. SEGSUP NOMID
  1770. ENDIF
  1771. C
  1772. IF(IPCHE3.NE.0) THEN
  1773. IF (ISUP3.EQ.1) THEN
  1774. CALL DTMVAL(IVARI,3)
  1775. ELSE
  1776. CALL DTMVAL(IVARI,1)
  1777. ENDIF
  1778. NOMID=MOVARI
  1779. if(lsupva)SEGSUP NOMID
  1780. ENDIF
  1781. C
  1782. IF (MCHAM1.NE.0) SEGSUP MCHAM1
  1783.  
  1784. 9991 CONTINUE
  1785. SEGSUP MCHEL1
  1786. IRET=0
  1787.  
  1788. 9992 CONTINUE
  1789.  
  1790. C On detruit le 2e modele. Les sous-zones viennent d'etre desactivees.
  1791. MMODE2 = IPMOD2
  1792. SEGSUP,MMODE2
  1793.  
  1794. END
  1795.  
  1796.  
  1797.  
  1798.  
  1799.  
  1800.  
  1801.  

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