Télécharger elas1.eso

Retour à la liste

Numérotation des lignes :

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

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