Télécharger elas1.eso

Retour à la liste

Numérotation des lignes :

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

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