Télécharger elas1.eso

Retour à la liste

Numérotation des lignes :

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

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