Télécharger elas1.eso

Retour à la liste

Numérotation des lignes :

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

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