Télécharger ktanga.eso

Retour à la liste

Numérotation des lignes :

  1. C KTANGA SOURCE PV 17/10/03 21:15:45 9581
  2.  
  3. SUBROUTINE KTANGA(IPMOD0,IPCHE1,IPCHE2,IPCHE3,XPREC,DTPS,IKTSYM,
  4. & IPRIGI)
  5.  
  6. *=======================================================================
  7. *= CALCUL DE LA MATRICE DE RIGIDITE TANGENTE =
  8. *=======================================================================
  9. *= Entrees : =
  10. *= --------- =
  11. *= IPMOD0 pointeur sur le mmodel =
  12. *= IPCHE1 pointeur sur le mchaml de contraintes =
  13. *= IPCHE2 pointeur sur le mchaml de variables internes =
  14. *= IPCHE3 pointeur sur le mchaml de caracteristiques =
  15. *= XPREC flottant precision =
  16. *= DTPS flottant pas de temps (modeles visco-plastiques) =
  17. *= IKTSYM =1 si matrice symetrique en sortie, =0 sinon =
  18. *=======================================================================
  19. *= Sortie : =
  20. *= -------- =
  21. *= IPRIGI pointeur sur matrice rigidite (=0 en cas d'erreur) =
  22. *=======================================================================
  23. *= Passage aux nouveaux chamelems par jm campenon le 05/91 =
  24. *= Mise a niveau FD/OF en 2009 =
  25. *=======================================================================
  26.  
  27. IMPLICIT INTEGER(I-N)
  28. IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC CCOPTIO
  31. -INC CCHAMP
  32. -INC CCGEOME
  33.  
  34. -INC SMCHAML
  35. -INC SMCOORD
  36. -INC SMELEME
  37. -INC SMINTE
  38. -INC SMLREEL
  39. -INC SMMODEL
  40. -INC SMRIGID
  41.  
  42. INTEGER OOOVAL
  43.  
  44. SEGMENT WRK1
  45. REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS),
  46. & REL(LRE,LRE),XE(3,NBBB)
  47. ENDSEGMENT
  48. *
  49. SEGMENT WRK2
  50. REAL*8 SHPWRK(6,NBNO),BGENE(NSTRS,LRE)
  51. ENDSEGMENT
  52. *
  53. SEGMENT WRK3
  54. REAL*8 WORK(LW)
  55. ENDSEGMENT
  56. *
  57. SEGMENT WRK4
  58. REAL*8 BPSS(3,3),XEL(3,NBBB)
  59. ENDSEGMENT
  60. *
  61. SEGMENT WRK5
  62. INTEGER NTRAC1,NTRAC2
  63. ENDSEGMENT
  64.  
  65. * POUR LES MATERIAUX a "TROPIE" (PASSAGE DE LA MATRICE DE ROTATION)
  66. SEGMENT WTRAV
  67. REAL*8 TXR(IDIM,IDIM)
  68. ENDSEGMENT
  69.  
  70. SEGMENT INFO
  71. INTEGER INFELL(JG)
  72. ENDSEGMENT
  73.  
  74. SEGMENT NOTYPE
  75. CHARACTER*16 TYPE(NBTYPE)
  76. ENDSEGMENT
  77.  
  78. SEGMENT MPTVAL
  79. INTEGER IPOS(NS),NSOF(NS)
  80. INTEGER IVAL(NCOSOU)
  81. CHARACTER*16 TYVAL(NCOSOU)
  82. ENDSEGMENT
  83.  
  84. C- Nombre de points maximal pour stocker une courbe de traction
  85. PARAMETER (LTRAC=2*75)
  86.  
  87. * INTTYP correspond au type de points d'integration utilise par KTAN
  88. PARAMETER ( INTTYP=3 )
  89.  
  90. DIMENSION TRAC(LTRAC)
  91. DIMENSION CRIGI(12),CMASS(12)
  92. DIMENSION A(4,60),BB(3,60)
  93. * Petit tableau des "couleurs" des relations de conformite
  94. DIMENSION LCOLOR(6)
  95. DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
  96.  
  97. CHARACTER*8 CMATE
  98. CHARACTER*(NCONCH) CONM
  99. PARAMETER ( NINF=3 )
  100. INTEGER INFOS(NINF)
  101. LOGICAL lsupdp,lsupfo,lsupco,lsupva,lsupma,
  102. & BDPGE,BPLAN,BMATE
  103.  
  104. *======================================================================*
  105. *= 1 - INITIALISATIONS ET VERIFICATIONS =*
  106. *======================================================================*
  107. IPRIGI=0
  108. KERRE=0
  109. * Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX")
  110. CALL PIMODL(IPMOD0,IPMODL)
  111. IF (IPMODL.EQ.0) RETURN
  112. * Verification du support du mchaml de CONTRAINTES
  113. CALL REDUAF(IPCHE1,IPMOD0,IPCH_Z,0,IRET,KERRE)
  114. IF (IRET.NE.1) CALL ERREUR(KERRE)
  115. IF (IERR.NE.0) GOTO 550
  116. IPCHE1=IPCH_Z
  117. CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUPCO,IRET)
  118. IF (ISUPCO.GT.1) GOTO 550
  119. * Verification du support du mchaml de VARIABLES INTERNES
  120. CALL REDUAF(IPCHE2,IPMOD0,IPCH_Z,0,IRET,KERRE)
  121. IF (IRET.NE.1) CALL ERREUR(KERRE)
  122. IF (IERR.NE.0) GOTO 550
  123. IPCHE2=IPCH_Z
  124. CALL QUESUP(IPMODL,IPCHE2,INTTYP,0,ISUPVA,IRET)
  125. IF (ISUPVA.GT.1) GOTO 550
  126. * Verification du support du mchaml de CARACTERISTIQUES
  127. CALL REDUAF(IPCHE3,IPMOD0,IPCH_Z,0,IRET,KERRE)
  128. IF (IRET.NE.1) CALL ERREUR(KERRE)
  129. IF (IERR.NE.0) GOTO 550
  130. IPCHE3=IPCH_Z
  131. CALL QUESUP(IPMODL,IPCHE3,INTTYP,0,ISUPMA,IRET)
  132. IF (ISUPMA.GT.1) GOTO 550
  133. * Activation du modele
  134. MMODEL=IPMODL
  135. SEGACT,MMODEL
  136. NSOUS=KMODEL(/1)
  137. * Initialisations de l'objet RIGIDITE "matrice tangente"
  138. NRIGEL=NSOUS
  139. SEGINI,MRIGID
  140. IPRIGI=MRIGID
  141. MTYMAT='RIGIDITE'
  142. ICHOLE=0
  143. IFORIG=IFOUR
  144. IMGEO1=0
  145. IMGEO2=0
  146. ISUPEQ=0
  147. NHRM=NIFOUR
  148. * Indicateur de mode de calcul en 2D plan
  149. BPLAN = IFOUR.EQ.-2 .OR. IFOUR.EQ.-1 .OR. IFOUR.EQ.-3
  150.  
  151. *======================================================================*
  152. *= 2 - BOUCLE SUR LES SOUS-ZONES DU MODELE (Fin = etiquette 500) =*
  153. *======================================================================*
  154. ISOU = 0
  155. *
  156. DO 500 ISOUS=1,NSOUS
  157. *
  158. IMODEL=KMODEL(ISOUS)
  159. SEGACT,IMODEL
  160. IPMOD1=IMODEL
  161. *-----------------------------------------------------------------------
  162. *- 2.1 - Intialisations et activations de segments
  163. *-----------------------------------------------------------------------
  164. MELE = imodel.NEFMOD
  165. IPMAIL = imodel.IMAMOD
  166. IIPDPG = imodel.IPDPGE
  167. IIPDPG = IPTPOI(IIPDPG)
  168. *
  169. IPINF = 0
  170. * Cas particulier des relations de conformites
  171. IF (MELE.EQ.22) GOTO 5001
  172. IF (MELE.EQ.259) GOTO 5001
  173. * Verifications sur la formulation
  174. CONM = CONMOD
  175. * NFOR = FORMOD(/2)
  176. * NMAT = MATMOD(/2)
  177. * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,MAPL)
  178. CMATE = CMATEE
  179. MATE = IMATEE
  180. MAPL = INATUU
  181. IF (CMATE.EQ.' ') THEN
  182. KERRE=251
  183. CALL ERREUR(KERRE)
  184. GOTO 551
  185. ENDIF
  186. BMATE = (CMATE.EQ.'UNIDIREC').OR.(CMATE.EQ.'ORTHOTRO').OR.
  187. & (CMATE.EQ.'ANISOTRO')
  188. * Information sur l'element fini
  189. IF (INFMOD(/1).LT.2+INTTYP) THEN
  190. CALL ELQUOI(MELE,0,INTTYP,IPINF,IPMOD1)
  191. IF (IERR.NE.0) THEN
  192. KERRE=-ABS(IERR)
  193. GOTO 551
  194. ENDIF
  195. INFO=IPINF
  196. NBGS=INFELL(4)
  197. C* ICARA=INFELL(5)
  198. NBPGAU=INFELL(6)
  199. LW =INFELL(7)
  200. IPORE=INFELL(8)
  201. LRE =INFELL(9)
  202. LHOOK=INFELL(10)
  203. MFR =INFELL(13)
  204. IELE =INFELL(14)
  205. NDDL =INFELL(15)
  206. C* NSTRS=INFELL(16)
  207. IPMINT=INFELL(11)
  208. IPMIN1=INFELL(12)
  209. SEGSUP,INFO
  210. ELSE
  211. NBGS =INFELE(4)
  212. C* ICARA=INFELE(5)
  213. NBPGAU=INFELE(6)
  214. LW =INFELE(7)
  215. IPORE=INFELE(8)
  216. LRE =INFELE(9)
  217. LHOOK=INFELE(10)
  218. MFR =INFELE(13)
  219. IELE =INFELE(14)
  220. NDDL =INFELE(15)
  221. C* NSTRS=INFELE(16)
  222. IPMINT=INFMOD(2+INTTYP)
  223. IPMIN1=INFMOD(8)
  224. ENDIF
  225. * Activation du segment d'integration MINTE=IPMINT
  226. MINTE=IPMINT
  227. IF (MELE.NE.260) SEGACT,MINTE
  228. *
  229. IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  230. IPPORE = NBNNE(NUMGEO(MELE))
  231. IF (IFOUR.EQ.1.OR.IFOUR.EQ.-3) THEN
  232. LHOOK=6
  233. ELSE
  234. LHOOK=4
  235. ENDIF
  236. ELSE IF (MFR.EQ.33) THEN
  237. IPPORE = NBNNE(NUMGEO(MELE))
  238. ELSE
  239. IPPORE = 0
  240. ENDIF
  241.  
  242. CALL INFDPG(MFR,IFOUR, BDPGE,NDPGE)
  243. * Coordonnees du point support des deformations planes generalisees
  244. IF (BDPGE) THEN
  245. IF (IIPDPG.LE.0) THEN
  246. CALL ERREUR(925)
  247. CALL ERREUR(5)
  248. GOTO 551
  249. ENDIF
  250. IREF=(IIPDPG-1)*(IDIM+1)
  251. XDPGE=XCOOR(IREF+1)
  252. YDPGE=XCOOR(IREF+2)
  253. ELSE
  254. XDPGE = 0.D0
  255. YDPGE = 0.D0
  256. ENDIF
  257. *-----------------------------------------------------------------------
  258. *- 2.2 - Preparation des objets resultats DESCR et XMATRI
  259. *-----------------------------------------------------------------------
  260. * Si necessaire PARTITIONNEMENT du segment XMATRI
  261. 5001 CONTINUE
  262. LTRK=OOOVAL(1,4)
  263. IF (LTRK.EQ.0) LTRK=OOOVAL(1,1)
  264. IPT1=IPMAIL
  265. SEGACT,IPT1
  266. NBNN1 =IPT1.NUM(/1)
  267. NBELE1=IPT1.NUM(/2)
  268. IF (MELE.EQ.22) LRE=NBNN1
  269. IF (MELE.EQ.259) LRE=NBNN1
  270. * Traitements particuliers pour penalisation milieu poreux
  271. IDECAP = 0
  272. IF (MELE.GE.79.AND.MELE.LE.83) THEN
  273. IDECAP = 1
  274. LRE = LRE + 2*NBNN1 - IPORE
  275. ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  276. IDECAP=1
  277. LRE = LRE + (3*NBNN1 - IPORE)/2 - NBSOM(IELE)
  278. ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  279. IDECAP=2
  280. LRE = LRE + (2*NBNN1 - IPORE)*IDECAP
  281. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  282. IDECAP=3
  283. LRE = LRE + (2*NBNN1 - IPORE)*IDECAP
  284. ENDIF
  285. * Ajout a la taille en mots de la matrice des infos du segment
  286. LSEG=LRE*LRE*NBELE1 + 16
  287. NBLPRT=(LSEG-1)/LTRK1
  288. NBLMAX=(NBELE1-1)/NBLPRT+1
  289. NBLPRT=(NBELE1-1)/NBLMAX+1
  290. * write(ioimp,*) ' ktanga nblprt nblmax ',NBLPRT,NBLMAX,NBELE1
  291. MELEME=IPT1
  292. * Boucle (5000) de PARTITIONNEMENT du segment XMATRI
  293. DO 5000 IPRT = 1,NBLPRT
  294. ISOU=ISOU+1
  295. IF (ISOU.GT.IRIGEL(/2)) THEN
  296. NRIGEL=ISOU
  297. SEGADJ,MRIGID
  298. ENDIF
  299. IF (NBLPRT.GT.1) THEN
  300. JPRT=(IPRT-1)*NBLMAX
  301. SEGACT,IPT1
  302. NBSOUS=0
  303. NBREF=0
  304. NBNN=NBNN1
  305. NBELEM=MIN(NBLMAX,NBELE1-JPRT)
  306. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  307. SEGINI,MELEME
  308. ITYPEL=IPT1.ITYPEL
  309. DO I=1,NBELEM
  310. IB=I+JPRT
  311. DO J=1,NBNN
  312. NUM(J,I)=IPT1.NUM(J,IB)
  313. ENDDO
  314. ICOLOR(I)=IPT1.ICOLOR(I)
  315. ENDDO
  316. ENDIF
  317. IPMAIL=MELEME
  318. * Fin du traitement particulier en cas de PARTITIONNEMENT du XMATRI
  319. * Quelques initialisations suite au partionnement
  320. IPDSCR = 0
  321. IPMADG = 0
  322. IPMATR = 0
  323. IRIGE7 = 0
  324. *
  325. NMATR = 0
  326. NMATF = 0
  327. IVAMAT = 0
  328. NCARA = 0
  329. NCARF = 0
  330. IVACAR = 0
  331. NVARI = 0
  332. NVARF = 0
  333. IVARI = 0
  334. IVACON = 0
  335. * Activation du MELEME support des rigidites
  336. MELEME=IPMAIL
  337. SEGACT,MELEME
  338. NBNN =NUM(/1)
  339. NBELEM=NUM(/2)
  340. * Cas particulier des relations de conformites
  341. IF (MELE.EQ.22) GOTO 22
  342. IF (MELE.EQ.259) GOTO 259
  343. * Modification du MELEME pour les deformations planes generalisees
  344. IF (BDPGE) THEN
  345. NBNA=NBNN
  346. NBNN=NBNA+1
  347. NBREF=0
  348. NBSOUS=0
  349. SEGINI,IPT2
  350. IPT2.ITYPEL=28
  351. DO I=1,NBELEM
  352. DO J=1,NBNA
  353. IPT2.NUM(J,I)=NUM(J,I)
  354. ENDDO
  355. IPT2.NUM(NBNN,I)=IIPDPG
  356. IPT2.ICOLOR(I)=ICOLOR(I)
  357. ENDDO
  358. SEGDES,IPT2
  359. IPMAGD=IPT2
  360. ENDIF
  361. * Recherche des noms d'inconnues primales et duales
  362. IF (LNOMID(1).NE.0) THEN
  363. lsupdp=.FALSE.
  364. NOMID=LNOMID(1)
  365. SEGACT,NOMID
  366. MODEPL=NOMID
  367. NDEPL=LESOBL(/2)
  368. ELSE
  369. lsupdp=.TRUE.
  370. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,ndum)
  371. NOMID=MODEPL
  372. SEGACT,NOMID
  373. ENDIF
  374. IF (LNOMID(2).NE.0) THEN
  375. lsupfo=.FALSE.
  376. NOMID=LNOMID(2)
  377. SEGACT,NOMID
  378. MOFORC=NOMID
  379. NFORC=LESOBL(/2)
  380. ELSE
  381. lsupfo=.TRUE.
  382. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,ndum)
  383. NOMID=MOFORC
  384. SEGACT,NOMID
  385. ENDIF
  386. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  387. KERRE=5
  388. GOTO 515
  389. ENDIF
  390. * Initialisation du segment DESCR
  391. NLIGRP = LRE
  392. NLIGRD = LRE
  393. SEGINI,DESCR
  394. IPDSCR=DESCR
  395. * Remplissage du segment DESCRipteur
  396. NCOMP = NDEPL
  397. NBNNS = NBNN
  398. IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  399. NCOMP = NDEPL-IDECAP
  400. ENDIF
  401. IF (BDPGE) THEN
  402. NCOMP = NDEPL-NDPGE
  403. NBNNS = NBNN-1
  404. ENDIF
  405. IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
  406. IDDL=1
  407. * Cas du macro-element
  408. IF (MFR.EQ.61)THEN
  409. DO i=1,3
  410. NOELEP(i )=1
  411. NOELEP(i+3)=3
  412. ENDDO
  413. NOELEP(7)=2
  414. NOELEP(8)=2
  415. DO i=1,LRE
  416. NOELED(i)=NOELEP(i)
  417. ENDDO
  418. NOMID=MODEPL
  419. DO i=1,3
  420. LISINC(i )=LESOBL(i)
  421. LISINC(i+3)=LESOBL(i)
  422. ENDDO
  423. LISINC(7)=LESOBL(4)
  424. LISINC(8)=LESOBL(5)
  425. NOMID=MOFORC
  426. DO i=1,3
  427. LISDUA(i )=LESOBL(i)
  428. LISDUA(i+3)=(i)
  429. ENDDO
  430. LISDUA(7)=LESOBL(4)
  431. LISDUA(8)=LESOBL(5)
  432. * Cas general
  433. ELSE
  434. * Erreur dans les dimensions de DESCR (mode de calcul incorrect)
  435. IF (NBNNS*NCOMP.GT.NLIGRD) THEN
  436. KERRE=717
  437. GOTO 515
  438. ENDIF
  439. NDUM=NBNNS
  440. IF (MELE.GE.108.AND.MELE.LE.110) THEN
  441. NFAC=(3*NBNN-IPORE)/2
  442. NDUM=MIN(NBNNS,NFAC)
  443. ENDIF
  444. DO INOEUD=1,NDUM
  445. DO ICOMP=1,NCOMP
  446. NOELEP(IDDL)=INOEUD
  447. NOELED(IDDL)=INOEUD
  448. NOMID=MODEPL
  449. LISINC(IDDL)=LESOBL(ICOMP)
  450. NOMID=MOFORC
  451. LISDUA(IDDL)=LESOBL(ICOMP)
  452. IDDL=IDDL+1
  453. ENDDO
  454. ENDDO
  455. ENDIF
  456. * Cas particulier des deformations planes generalisees
  457. IF (BDPGE) THEN
  458. DO ICOMP=(NDPGE-1),0,-1
  459. NOELEP(IDDL)=NBNN
  460. NOELED(IDDL)=NBNN
  461. NOMID=MODEPL
  462. LISINC(IDDL)=LESOBL(NDEPL-ICOMP)
  463. NOMID=MOFORC
  464. LISDUA(IDDL)=LESOBL(NFORC-ICOMP)
  465. IDDL=IDDL+1
  466. ENDDO
  467. ENDIF
  468. * Cas particulier des milieux poreux (pression aux sommets en 1er)
  469. IF (MFR.EQ.33) THEN
  470. DO INOEUD=1,NBSOM(IELE)
  471. NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  472. NOELED(IDDL)=NOELEP(IDDL)
  473. NOMID=MODEPL
  474. LISINC(IDDL)=LESOBL(NDEPL)
  475. NOMID=MOFORC
  476. LISDUA(IDDL)=LESOBL(NDEPL)
  477. IDDL=IDDL+1
  478. ENDDO
  479. IF (MELE.GE.79.AND.MELE.LE.83) THEN
  480. DO 1105 INOEUD=1,NBNN
  481. DO i=1,NBSOM(IELE)
  482. IF (INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1105
  483. ENDDO
  484. NOELEP(IDDL)=INOEUD
  485. NOELED(IDDL)=INOEUD
  486. NOMID=MODEPL
  487. LISINC(IDDL)=LESOBL(NDEPL)
  488. NOMID=MOFORC
  489. LISDUA(IDDL)=LESOBL(NDEPL)
  490. IDDL=IDDL+1
  491. 1105 CONTINUE
  492. ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  493. DO INOEUD=NFAC+1,NBNN
  494. NOELEP(IDDL)=INOEUD
  495. NOELED(IDDL)=INOEUD
  496. NOMID=MODEPL
  497. LISINC(IDDL)=LESOBL(NDEPL)
  498. NOMID=MOFORC
  499. LISDUA(IDDL)=LESOBL(NDEPL)
  500. IDDL=IDDL+1
  501. ENDDO
  502. DO 1110 INOEUD=1,NFAC
  503. DO i=1,NBSOM(IELE)
  504. IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1110
  505. ENDDO
  506. NOELEP(IDDL)=INOEUD
  507. NOELED(IDDL)=INOEUD
  508. NOMID=MODEPL
  509. LISINC(IDDL)=LESOBL(NDEPL)
  510. NOMID=MOFORC
  511. LISDUA(IDDL)=LESOBL(NDEPL)
  512. IDDL=IDDL+1
  513. 1110 CONTINUE
  514. ENDIF
  515. ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  516. IF (MELE.GE.173.AND.MELE.LE.182) THEN
  517. DO IPR=1,IDECAP
  518. NDECAP = NDEPL-IDECAP+IPR
  519. DO INOEUD=1,NBSOM(IELE)
  520. NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  521. NOELED(IDDL)=NOELEP(IDDL)
  522. NOMID=MODEPL
  523. LISINC(IDDL)=LESOBL(NDECAP)
  524. NOMID=MOFORC
  525. LISDUA(IDDL)=LESOBL(NDECAP)
  526. IDDL=IDDL+1
  527. ENDDO
  528. DO 1205 INOEUD=1,NBNN
  529. DO i=1,NBSOM(IELE)
  530. IF (INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1205
  531. ENDDO
  532. NOELEP(IDDL)=INOEUD
  533. NOELED(IDDL)=INOEUD
  534. NOMID=MODEPL
  535. LISINC(IDDL)=LESOBL(NDECAP)
  536. NOMID=MOFORC
  537. LISDUA(IDDL)=LESOBL(NDECAP)
  538. IDDL=IDDL+1
  539. 1205 CONTINUE
  540. ENDDO
  541. ENDIF
  542. * Cas des elements raccord
  543. ELSE 4span$sTyle="color: #0033ff; font-weight: bold;">IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  544. CALL IDPRIM(IMODEL,MFR+1000,MODPL,NDEPL,ndum)
  545. NOMID=MODPL
  546. SEGACT,NOMID
  547. CALL IDDUAL(IMODEL,MFR+1000,MOFRC,NFORC,ndum)
  548. NOMID=MOFRC
  549. SEGACT,NOMID
  550. DO INOEUD=NBNNS+1,NBNN
  551. DO ICOMP=1,NDEPL
  552. NOELEP(IDDL)=INOEUD
  553. NOELED(IDDL)=INOEUD
  554. NOMID=MODPL
  555. LISINC(IDDL)=LESOBL(ICOMP)
  556. NOMID=MOFRC
  557. LISDUA(IDDL)=LESOBL(ICOMP)
  558. IDDL=IDDL+1
  559. ENDDO
  560. ENDDO
  561. NOMID=MODPL
  562. SEGSUP,NOMID
  563. NOMID=MOFRC
  564. SEGSUP,NOMID
  565. ENDIF
  566. * Initialisation du segment XMATRI contenant les matrices elementaires
  567. * de la sous-zone (NBELEM = nombre d'elements dans la sous-zone =MELEME)
  568. NELRIG=NBELEM
  569. SEGINI,XMATRI
  570. IPMATR=XMATRI
  571. * Quelques donnes utiles pour le segment MRIGID
  572. IF (BDPGE) THEN
  573. ** MELEME=IPMAIL <- MELEME segment actif et pointe tjs sur IPMAIL
  574. NBNN=NUM(/1)
  575. ELSE
  576. IPMAGD=IPMAIL
  577. ENDIF
  578. IF (MAPL.EQ.35.OR.MAPL.EQ.54.OR.MAPL.EQ.56.OR.MAPL.EQ.111) THEN
  579. IRIGE7=2
  580. ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  581. IRIGE7=2
  582. ELSE
  583. IRIGE7=0
  584. ENDIF
  585. * En cas de rendement IRIGE7=2 (cf. RIGI1.ESO)
  586. *-----------------------------------------------------------------------
  587. *- 2.3 - Analyse des champs par element fournis en entree
  588. *-----------------------------------------------------------------------
  589. * Creation du tableau infos (contraintes, variables internes)
  590. CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRET)
  591. IF (IRET.EQ.0) THEN
  592. KERRE=-ABS(IERR)
  593. GOTO 515
  594. ENDIF
  595. * Recherche des noms de composantes du champ de CONTRAINTEs
  596. IF (LNOMID(4).NE.0) THEN
  597. lsupco=.false.
  598. NOMID=LNOMID(4)
  599. SEGACT,NOMID
  600. MOCONT=NOMID
  601. NSTRS=LESOBL(/2)
  602. C* NFAC=LESFAC(/2)
  603. ELSE
  604. lsupco=.true.
  605. CALL IDCONT(IPMOD1,IFOUR,MOCONT,NSTRS,NFAC)
  606. ENDIF
  607. * Type des composantes
  608. NBTYPE=1
  609. SEGINI,NOTYPE
  610. TYPE(1)='REAL*8'
  611. MOTYPE=NOTYPE
  612. * Verification de leur presence
  613. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCONT,MOTYPE,1,INFOS,3,IVACON)
  614. SEGSUP,NOTYPE
  615. NOMID=MOCONT
  616. IF (lsupco) SEGSUP,NOMID
  617. IF (IERR.NE.0) THEN
  618. KERRE=-ABS(IERR)
  619. GOTO 515
  620. ENDIF
  621. IF (ISUPCO.EQ.1) THEN
  622. CALL VALCHE(IVACON,NSTRS,IPMINT,IPPORE,MOCONT,MELE)
  623. IF (IERR.NE.0) THEN
  624. ISUPCO=0
  625. KERRE=-ABS(IERR)
  626. GOTO 515
  627. ENDIF
  628. ENDIF
  629. * Recherche des noms de composantes du champ des variables internes
  630. IF (LNOMID(10).NE.0) THEN
  631. lsupva=.false.
  632. NOMID=LNOMID(10)
  633. SEGACT,NOMID
  634. MOVARI=NOMID
  635. NVARI=LESOBL(/2)
  636. NVARF=LESFAC(/2)
  637. ELSE
  638. lsupva=.true.
  639. CALL IDVARI(MFR,IPMOD1,MOVARI,NVARI,NVARF)
  640. ENDIF
  641. IF (MOVARI.EQ.0) THEN
  642. KERRE=76
  643. MOTERR(1:4)='VARI'
  644. MOTERR(5:8)=NOMTP(MELE)
  645. GOTO 515
  646. ENDIF
  647. NVART=NVARI+NVARF
  648. * Type des composantes
  649. NBTYPE=1
  650. SEGINI,NOTYPE
  651. TYPE(1)='REAL*8'
  652. IF (CMATE.EQ.'SECTION') TYPE(1)='POINTEURMCHAML '
  653. MOTYPE=NOTYPE
  654. * Verification de leur presence
  655. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOVARI,MOTYPE,1,INFOS,3,IVARI)
  656. SEGSUP,NOTYPE
  657. NOMID=MOVARI
  658. IF (lsupva) SEGSUP,NOMID
  659. IF (IERR.NE.0) THEN
  660. KERRE=-ABS(IERR)
  661. GOTO 515
  662. ENDIF
  663. IF (ISUPVA.EQ.1) THEN
  664. CALL VALCHE(IVARI,NVART,IPMINT,IPPORE,MOVARI,MELE)
  665. IF (IERR.NE.0) THEN
  666. ISUPVA=0
  667. KERRE=-ABS(IERR)
  668. GOTO 515
  669. ENDIF
  670. ENDIF
  671. * Creation du tableau infos (variables internes, caracteristiques)
  672. CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE3,INFOS,IRET)
  673. IF (IRET.EQ.0) THEN
  674. KERRE=-ABS(IERR)
  675. GOTO 515
  676. ENDIF
  677. * Recuperation des noms de composantes de caracteristiques materielles
  678. * Sauf cas particulier MOTYPE = segment NBTYPE=1 et TYPE(1)='REAL*8'
  679. NBTYPE=1
  680. SEGINI,NOTYPE
  681. TYPE(1)='REAL*8'
  682. MOTYPE=NOTYPE
  683. NBROBL=0
  684. NBRFAC=0
  685. NOMID=0
  686. lsupma=.TRUE.
  687. * Element de barre et Acier Unidirirectionnel
  688. IF (MAPL.EQ.40.AND.MFR.EQ.27) THEN
  689. NBROBL=1
  690. SEGINI,NOMID
  691. LESOBL(1)='YOUN'
  692. ELSE IF (MFR.EQ.7.AND.CMATE.EQ.'SECTION') THEN
  693. NBROBL=2
  694. NBRFAC=1
  695. SEGINI,NOMID
  696. LESOBL(1)='MODS'
  697. LESOBL(2)='MATS'
  698. LESFAC(1)='MAHO'
  699. NBTYPE=3
  700. SEGADJ,NOTYPE
  701. TYPE(1)='POINTEURMMODEL '
  702. TYPE(2)='POINTEURMCHAML '
  703. TYPE(3)='POINTEURLISTREEL'
  704. * Cas POI1 -- MODAL -- MFR=26 ==> pas traite dans la suite
  705. ELSE IF (MFR.EQ.26) THEN
  706. NBROBL=3
  707. SEGINI,NOMID
  708. LESOBL(1)='FREQ'
  709. LESOBL(2)='MASS'
  710. LESOBL(3)='DEFO'
  711. NBTYPE=3
  712. SEGADJ,NOTYPE
  713. TYPE(1)='REAL*8'
  714. TYPE(2)='REAL*8'
  715. TYPE(3)='POINTEURCHPOINT'
  716. * Cas POI1 -- STATIQUE -- MFR=28 ==> pas traite dans la suite
  717. ELSE IF (MFR.EQ.28) THEN
  718. NBROBL=3
  719. SEGINI,NOMID
  720. LESOBL(1)='DEFO'
  721. LESOBL(2)='RIDE'
  722. LESOBL(3)='MADE'
  723. TYPE(1)='POINTEURCHPOINT'
  724. * Cas Orthotrope, Anisotrope et Unidirectionnel
  725. ELSE IF (BMATE) THEN
  726. * Materiau Unidirirectionnel
  727. C*? IF (FORMOD(/1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN
  728. IF (CMATE.EQ.'UNIDIREC') THEN
  729. IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN
  730. NBROBL=7
  731. SEGINI,NOMID
  732. LESOBL(1)='YOUN'
  733. LESOBL(2)='V1X '
  734. LESOBL(3)='V1Y '
  735. LESOBL(4)='V1Z '
  736. LESOBL(5)='V2X '
  737. LESOBL(6)='V2Y '
  738. LESOBL(7)='V2Z '
  739. ELSE
  740. NBROBL=3
  741. SEGINI,NOMID
  742. LESOBL(1)='YOUN'
  743. LESOBL(2)='V1X '
  744. LESOBL(3)='V1Y '
  745. ENDIF
  746. * Materiau orthotrope plastique 'ECROUIS_DECOU'
  747. ELSE IF (CMATE.EQ.'ORTHOTRO'.AND.MAPL.EQ.67) THEN
  748. NBROBL=6
  749. SEGINI,NOMID
  750. LESOBL(1)='YG1 '
  751. LESOBL(2)='YG2 '
  752. LESOBL(3)='NU12'
  753. LESOBL(4)='G12 '
  754. LESOBL(5)='V1X '
  755. LESOBL(6)='V1Y '
  756. * Autres Materiaux orthotropes et anisotropes
  757. ELSE
  758. IF (LNOMID(6).NE.0) THEN
  759. lsupma=.FALSE.
  760. NOMID=LNOMID(6)
  761. SEGACT,NOMID
  762. NBROBL=LESOBL(/2)
  763. NBRFAC=LESFAC(/2)
  764. ELSE
  765. CALL IDMATR(MFR,IPMOD1,MOMATR,NBROBL,NBRFAC)
  766. ENDIF
  767. * Cas particulier : Mistral (10 composantes = listes de reels)
  768. IF (MAPL.EQ.94) THEN
  769. NBTYPE=NBROBL+NBRFAC
  770. SEGADJ,NOTYPE
  771. DO i=1,NBTYPE
  772. TYPE(i)='REAL*8'
  773. ENDDO
  774. NLDEB=NBROBL-9
  775. DO i=NLDEB,NBROBL
  776. TYPE(i)='POINTEURLISTREEL'
  777. ENDDO
  778. ENDIF
  779. ENDIF
  780. * Materiaux ISOTROPEs
  781. ELSE IF (CMATE.EQ.'ISOTROPE') THEN
  782. IF (MFR.EQ.35) THEN
  783. IF (MAPL.EQ.35) THEN
  784. NBROBL=4
  785. SEGINI,NOMID
  786. LESOBL(1)='KS '
  787. LESOBL(2)='KN '
  788. LESOBL(3)='PHI '
  789. LESOBL(4)='MU '
  790. ELSE
  791. NBROBL=2
  792. SEGINI,NOMID
  793. LESOBL(1)='KS '
  794. LESOBL(2)='KN '
  795. ENDIF
  796. * Element joint cisaillement 2D
  797. ELSE IF (MFR.EQ.53) THEN
  798. NBROBL=1
  799. SEGINI,NOMID
  800. LESOBL(1)='KS '
  801. * Elements POREUX isotropes
  802. ELSE IF (FORMOD(1).EQ.'POREUX') THEN
  803. IF (MELE.GE.79.AND.MELE.LE.83) THEN
  804. NBROBL=4
  805. SEGINI,NOMID
  806. LESOBL(1)='YOUN'
  807. LESOBL(2)='NU '
  808. LESOBL(3)='COB '
  809. LESOBL(4)='MOB '
  810. ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  811. NBROBL=4
  812. SEGINI,NOMID
  813. LESOBL(1)='KS '
  814. LESOBL(2)='KN '
  815. LESOBL(3)='COB '
  816. LESOBL(4)='MOB '
  817. ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  818. NBROBL=10
  819. SEGINI,NOMID
  820. LESOBL(1)='YOUN'
  821. LESOBL(2)='NU '
  822. LESOBL(3)='COP1'
  823. LESOBL(4)='COP2'
  824. LESOBL(5)='CPP1'
  825. LESOBL(6)='CPP2'
  826. LESOBL(7)='KK11'
  827. LESOBL(8)='KK12'
  828. LESOBL(9)='KK21'
  829. LESOBL(10)='KK22'
  830. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  831. NBROBL=17
  832. SEGINI,NOMID
  833. LESOBL(1)='YOUN'
  834. LESOBL(2)='NU '
  835. LESOBL(3)='COP1'
  836. LESOBL(4)='COP2'
  837. LESOBL(5)='COP3'
  838. LESOBL(6)='CPP1'
  839. LESOBL(7)='CPP2'
  840. LESOBL(8)='CPP3'
  841. LESOBL(9)='KK11'
  842. LESOBL(10)='KK12'
  843. LESOBL(11)='KK13'
  844. LESOBL(12)='KK21'
  845. LESOBL(13)='KK22'
  846. LESOBL(14)='KK23'
  847. LESOBL(15)='KK31'
  848. LESOBL(16)='KK32'
  849. LESOBL(17)='KK33'
  850. ENDIF
  851. ELSE IF (MAPL.EQ.1) THEN
  852. NBROBL=3
  853. SEGINI,NOMID
  854. LESOBL(1)='YOUN'
  855. LESOBL(2)='NU '
  856. LESOBL(3)='SIGY'
  857. ELSE IF (MAPL.EQ.2.OR.MAPL.EQ.14) THEN
  858. NBROBL=2
  859. NBRFAC=2
  860. SEGINI,NOMID
  861. LESOBL(1)='YOUN'
  862. LESOBL(2)='NU '
  863. LESFAC(1)='SIGF'
  864. LESFAC(2)='TRAC'
  865. NBTYPE=4
  866. SEGADJ,NOTYPE
  867. TYPE(1)='REAL*8'
  868. TYPE(2)='REAL*8'
  869. TYPE(3)='REAL*8'
  870. TYPE(4)='POINTEUREVOLUTIO'
  871. ELSE IF (MAPL.EQ.3) THEN
  872. NBROBL=4
  873. SEGINI,NOMID
  874. LESOBL(1)='YOUN'
  875. LESOBL(2)='NU '
  876. LESOBL(3)='LTR '
  877. LESOBL(4)='LCS '
  878. ELSE IF (MAPL.EQ.4) THEN
  879. NBROBL=4
  880. SEGINI,NOMID
  881. LESOBL(1)='YOUN'
  882. LESOBL(2)='NU '
  883. LESOBL(3)='SIGY'
  884. LESOBL(4)='H '
  885. ELSE IF (MAPL.EQ.5) THEN
  886. NBROBL=3
  887. SEGINI,NOMID
  888. LESOBL(1)='YOUN'
  889. LESOBL(2)='NU '
  890. LESOBL(3)='TRAC'
  891. NBTYPE=3
  892. SEGADJ,NOTYPE
  893. TYPE(1)='REAL*8'
  894. TYPE(2)='REAL*8'
  895. TYPE(3)='POINTEUREVOLUTIO'
  896. * Modele Drucker Prager
  897. ELSE IF (MAPL.EQ.15) THEN
  898. NBROBL=11
  899. SEGINI,NOMID
  900. LESOBL(1) ='YOUN'
  901. LESOBL(2) ='NU '
  902. LESOBL(3) ='ETA '
  903. LESOBL(4) ='MU '
  904. LESOBL(5) ='KL '
  905. LESOBL(6) ='GAMM'
  906. LESOBL(7) ='DELT'
  907. LESOBL(8) ='ALFA'
  908. LESOBL(9) ='BETA'
  909. LESOBL(10)='K '
  910. LESOBL(11)='H '
  911. * Modele visco-plastique parfait
  912. ELSE IF (MAPL.EQ.43) THEN
  913. NBROBL=5
  914. SEGINI,NOMID
  915. LESOBL(1)='YOUN'
  916. LESOBL(2)='NU '
  917. LESOBL(3)='SIGY'
  918. LESOBL(4)='N '
  919. LESOBL(5)='K '
  920. * Modele Betocyclique
  921. ELSE IF (MAPL.EQ.54) THEN
  922. NBROBL=13
  923. SEGINI,NOMID
  924. LESOBL(1)='YOUN'
  925. LESOBL(2)='NU '
  926. LESOBL(3)='HHH1'
  927. LESOBL(4)='FTPE'
  928. LESOBL(5)='FCPE'
  929. LESOBL(6)='FTGR'
  930. LESOBL(7)='FCGR'
  931. LESOBL(8)='EPSO'
  932. LESOBL(9)='WOR0'
  933. LESOBL(10)='LCAT'
  934. LESOBL(11)='LCAC'
  935. LESOBL(12)='TREV'
  936. LESOBL(13)='COEV'
  937. NBTYPE=13
  938. SEGADJ,NOTYPE
  939. DO i=1,NBTYPE
  940. TYPE(i)='REAL*8'
  941. ENDDO
  942. TYPE(12)='POINTEUREVOLUTIO'
  943. TYPE(13)='POINTEUREVOLUTIO'
  944. * Rotating Crack
  945. ELSE IF (MAPL.EQ.55) THEN
  946. NBROBL=6
  947. SEGINI,NOMID
  948. LESOBL(1)='YOUN'
  949. LESOBL(2)='NU '
  950. LESOBL(3)='FTRA'
  951. LESOBL(4)='EPSR'
  952. LESOBL(5)='FRES'
  953. LESOBL(6)='BETA'
  954. * BCN-MRS-Lade (MAPL=111)
  955. ELSE IF (MAPL.EQ.111) THEN
  956. NBROBL=20
  957. SEGINI,NOMID
  958. LESOBL(1)='YOUN'
  959. LESOBL(2)='NU '
  960. LESOBL(3)='PC '
  961. LESOBL(4)='PA '
  962. LESOBL(5)='QA '
  963. LESOBL(6)='EXPM'
  964. LESOBL(7)='E '
  965. LESOBL(8)='K1 '
  966. LESOBL(9)='K2 '
  967. LESOBL(10)='ETAB'
  968. LESOBL(11)='EXPV'
  969. LESOBL(12)='EPSI'
  970. LESOBL(13)='N '
  971. LESOBL(14)='CCON'
  972. LESOBL(15)='EXPL'
  973. LESOBL(16)='PCAP'
  974. LESOBL(17)='EXPR'
  975. LESOBL(18)='CCAP'
  976. LESOBL(19)='PHI '
  977. LESOBL(20)='ALP '
  978. * BCN-J2 (MAPL=112)
  979. ELSE IF (MAPL.EQ.112) THEN
  980. NBROBL=6
  981. SEGINI,NOMID
  982. LESOBL(1)='YOUN'
  983. LESOBL(2)='NU '
  984. LESOBL(3)='SIG0'
  985. LESOBL(4)='SIGI'
  986. LESOBL(5)='KISO'
  987. LESOBL(6)='VELO'
  988. * BCN-Rounded Hyperbolic Mohr-Coulomb (MAPL=113)
  989. ELSE IF (MAPL.EQ.113) THEN
  990. NBROBL=4
  991. SEGINI,NOMID
  992. LESOBL(1)='YOUN'
  993. LESOBL(2)='NU '
  994. LESOBL(3)='COHE'
  995. LESOBL(4)='PHI '
  996. * Autres modeles ISOTROPEs : elasticite
  997. ELSE
  998. NBROBL=2
  999. SEGINI,NOMID
  1000. LESOBL(1)='YOUN'
  1001. LESOBL(2)='NU '
  1002. ENDIF
  1003. * Autres cas ?
  1004. ELSE
  1005. IF (LNOMID(6).NE.0) THEN
  1006. lsupma=.FALSE.
  1007. NOMID=LNOMID(6)
  1008. SEGACT,NOMID
  1009. NBROBL=LESOBL(/2)
  1010. NBRFAC=LESFAC(/2)
  1011. ELSE
  1012. CALL IDMATR(MFR,IPMOD1,MOMATR,NBROBL,NBRFAC)
  1013. ENDIF
  1014. IF (CMATE.EQ.'SECTION') THEN
  1015. NBTYPE=3
  1016. SEGADJ,NOTYPE
  1017. TYPE(1)='POINTEURMMODEL'
  1018. TYPE(2)='POINTEURMCHAML'
  1019. TYPE(3)='POINTEURLISTREEL'
  1020. ENDIF
  1021. ENDIF
  1022. MOMATR=NOMID
  1023. IF (MOMATR.EQ.0) THEN
  1024. SEGSUP,NOTYPE
  1025. KERRE=591
  1026. GOTO 515
  1027. ENDIF
  1028. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1029. SEGSUP,NOTYPE
  1030. IF (lsupma) SEGSUP,NOMID
  1031. IF (IERR.NE.0) THEN
  1032. KERRE=-ABS(IERR)
  1033. GOTO 515
  1034. ENDIF
  1035. NMATR=NBROBL
  1036. NMATF=NBRFAC
  1037. NMATT=NMATR+NMATF
  1038. IF (ISUPMA.EQ.1) THEN
  1039. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1040. IF (IERR.NE.0) THEN
  1041. ISUPMA=0
  1042. KERRE=-ABS(IERR)
  1043. GOTO 515
  1044. ENDIF
  1045. ENDIF
  1046. * Recuperation des noms de composantes de caracteristiques geometriques
  1047. * Sauf cas particulier MOTYPE = segment NBTYPE=1 et TYPE(1)='REAL*8'
  1048. NBTYPE=1
  1049. SEGINI,NOTYPE
  1050. TYPE(1)='REAL*8'
  1051. MOTYPE=NOTYPE
  1052. NBROBL=0
  1053. NBRFAC=0
  1054. NOMID=0
  1055. IVECT=0
  1056. * Massif ou certains elements poreux en contraintes planes
  1057. IF ( (MFR.EQ.1 .OR. MFR.EQ.31 .OR.
  1058. & (MELE.GE.79.AND.MELE.LE.83) .OR.
  1059. & (MELE.GE.173.AND.MELE.LE.182) )
  1060. & .AND. IFOUR.EQ.-2 ) THEN
  1061. NBRFAC=1
  1062. SEGINI,NOMID
  1063. LESFAC(1)='DIM3'
  1064. * Cas des coques
  1065. ELSE IF (MFR.EQ.3 .OR. MFR.EQ.5 .OR. MFR.EQ.9) THEN
  1066. NBROBL=1
  1067. IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  1068. NBRFAC=3
  1069. ELSE
  1070. NBRFAC=2
  1071. ENDIF
  1072. SEGINI,NOMID
  1073. LESOBL(1)='EPAI'
  1074. LESFAC(1)='EXCE'
  1075. IF (MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3'
  1076. LESFAC(NBRFAC)='CALF'
  1077. * Donnees pour les poutres
  1078. ELSE IF (MFR.EQ.7) THEN
  1079. IF (CMATE.NE.'SECTION' ) THEN
  1080. IF (BPLAN) THEN
  1081. NBRFAC=1
  1082. NBROBL=2
  1083. SEGINI,NOMID
  1084. LESOBL(1)='SECT'
  1085. LESOBL(2)='INRZ'
  1086. LESFAC(1)='SECY'
  1087. ELSE
  1088. NBROBL=4
  1089. NBRFAC=3
  1090. SEGINI,NOMID
  1091. LESOBL(1)='TORS'
  1092. LESOBL(2)='INRY'
  1093. LESOBL(3)='INRZ'
  1094. LESOBL(4)='SECT'
  1095. LESFAC(1)='SECY'
  1096. LESFAC(2)='SECZ'
  1097. LESFAC(3)='VECT'
  1098. IVECT=1
  1099. NBTYPE=7
  1100. SEGADJ,NOTYPE
  1101. TYPE(1)='REAL*8'
  1102. TYPE(2)='REAL*8'
  1103. TYPE(3)='REAL*8'
  1104. TYPE(4)='REAL*8'
  1105. TYPE(5)='REAL*8'
  1106. TYPE(6)='REAL*8'
  1107. TYPE(7)='POINTEURPOINT '
  1108. ENDIF
  1109. ELSE
  1110. NBRFAC=1
  1111. SEGINI,NOMID
  1112. LESFAC(1)='VECT'
  1113. IVECT=1
  1114. TYPE(1)='POINTEURPOINT '
  1115. ENDIF
  1116. C Donnees pour les TUYAUX
  1117. ELSE IF (MFR.EQ.13) THEN
  1118. NBROBL=2
  1119. NBRFAC=4
  1120. SEGINI,NOMID
  1121. LESOBL(1)='EPAI'
  1122. LESOBL(2)='RAYO'
  1123. LESFAC(1)='RACO'
  1124. LESFAC(2)='PRES'
  1125. LESFAC(3)='CISA'
  1126. LESFAC(4)='VECT'
  1127. IVECT=1
  1128. NBTYPE=6
  1129. SEGADJ,NOTYPE
  1130. TYPE(1)='REAL*8'
  1131. TYPE(2)='REAL*8'
  1132. TYPE(3)='REAL*8'
  1133. TYPE(4)='REAL*8'
  1134. TYPE(5)='REAL*8'
  1135. TYPE(6)='POINTEURPOINT '
  1136. C Donnees pour le LINESPRING
  1137. ELSE IF (MFR.EQ.15) THEN
  1138. NBROBL=5
  1139. SEGINI,NOMID
  1140. LESOBL(1)='EPAI'
  1141. LESOBL(2)='FISS'
  1142. LESOBL(3)='VX '
  1143. LESOBL(4)='VY '
  1144. LESOBL(5)='VZ '
  1145. C Donnees pour le TUYAU FISSURE
  1146. ELSE IF (MFR.EQ.17) THEN
  1147. NBROBL=9
  1148. SEGINI,NOMID
  1149. LESOBL(1)='RAYO'
  1150. LESOBL(2)='EPAI'
  1151. LESOBL(3)='VX '
  1152. LESOBL(4)='VY '
  1153. LESOBL(5)='VZ '
  1154. LESOBL(6)='VXF '
  1155. LESOBL(7)='VYF '
  1156. LESOBL(8)='VZF '
  1157. LESOBL(9)='ANGL'
  1158. * Section pour les barres - uniaxial
  1159. ELSE IF (MFR.EQ.27 .AND. CMATE.NE.'NODAL') THEN
  1160. NBROBL=1
  1161. SEGINI,NOMID
  1162. LESOBL(1)='SECT'
  1163. * Elements homogeneises
  1164. ELSE IF (MFR.EQ.37) THEN
  1165. IF (IFOUR.EQ.1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.2) THEN
  1166. NBROBL=5
  1167. SEGINI,NOMID
  1168. LESOBL(1)='SCEL'
  1169. LESOBL(2)='SFLU'
  1170. LESOBL(3)='EPS '
  1171. LESOBL(4)='SECT'
  1172. LESOBL(5)='INRZ '
  1173. ELSE
  1174. NBROBL=3
  1175. SEGINI,NOMID
  1176. LESOBL(1)='SCEL'
  1177. LESOBL(2)='SFLU'
  1178. LESOBL(3)='EPS '
  1179. ENDIF
  1180. * Element TUYO
  1181. ELSE IF (MFR.EQ.39) THEN
  1182. NBROBL=2
  1183. NBRFAC=3
  1184. SEGINI,NOMID
  1185. LESOBL(1)='EPAI'
  1186. LESOBL(2)='RAYO'
  1187. LESFAC(1)='RACO'
  1188. LESFAC(2)='PRES'
  1189. LESFAC(3)='VECT'
  1190. IVECT=1
  1191. NBTYPE=5
  1192. SEGADJ,NOTYPE
  1193. TYPE(1)='REAL*8'
  1194. TYPE(2)='REAL*8'
  1195. TYPE(3)='REAL*8'
  1196. TYPE(4)='REAL*8'
  1197. TYPE(5)='POINTEURPOINT '
  1198. * Element tuyau acoustique pure
  1199. ELSE IF (MFR.EQ.41) THEN
  1200. NBROBL=1
  1201. NBRFAC=1
  1202. SEGINI,NOMID
  1203. LESOBL(1)='RAYO'
  1204. LESFAC(1)='RACO'
  1205. * Donnees pour les barres excentrees
  1206. ELSE IF (MFR.EQ.49) THEN
  1207. NBROBL=6
  1208. SEGINI,NOMID
  1209. LESOBL(1)='SECT'
  1210. LESOBL(2)='EXCZ'
  1211. LESOBL(3)='EXCY'
  1212. LESOBL(4)='VX '
  1213. LESOBL(5)='VY '
  1214. LESOBL(6)='VZ '
  1215. * Donnees geometriques pour l'element LIA2 de liaison a 2 noeuds
  1216. ELSE IF (MFR.EQ.51) THEN
  1217. NBROBL=9
  1218. SEGINI,NOMID
  1219. LESOBL(1)='RLUX'
  1220. LESOBL(2)='RLUY'
  1221. LESOBL(3)='RLUZ'
  1222. LESOBL(4)='RLRX'
  1223. LESOBL(5)='RLRY'
  1224. LESOBL(6)='RLRZ'
  1225. LESOBL(7)='VX '
  1226. LESOBL(8)='VY '
  1227. LESOBL(9)='VZ '
  1228. * Elements de JOINTs GENE
  1229. ELSE IF (MFR.EQ.55) THEN
  1230. NBRFAC=1
  1231. SEGINI,NOMID
  1232. LESFAC(1)='EPAI'
  1233. * Macro element (element CIFL)
  1234. ELSE IF (MFR.EQ.61)THEN
  1235. NBROBL=2
  1236. SEGINI,NOMID
  1237. LESOBL(1)='SECT'
  1238. LESOBL(2)='INRZ'
  1239. ENDIF
  1240. * dans RIGI1.ESO : ajout de composantes facultatives pour le rendement
  1241. MOCARA=NOMID
  1242. NCARA=NBROBL
  1243. NCARF=NBRFAC
  1244. NCART=NCARA+NCARF
  1245. IF (MOCARA.NE.0) THEN
  1246. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
  1247. SEGSUP,NOTYPE,NOMID
  1248. IF (IERR.NE.0) THEN
  1249. KERRE=-ABS(IERR)
  1250. GOTO 515
  1251. ENDIF
  1252. IF (ISUPMA.EQ.1) THEN
  1253. CALL VALCHE(IVACAR,NCART,IPMINT,IPPORE,MOCARA,MELE)
  1254. IF (IERR.NE.0) THEN
  1255. ISUPMA=0
  1256. KERRE=-ABS(IERR)
  1257. GOTO 515
  1258. ENDIF
  1259. ENDIF
  1260. ELSE
  1261. SEGSUP,NOTYPE
  1262. ENDIF
  1263.  
  1264. * dans RIGI1.ESO : 1) utilisation de la densite pour ponderer la prop
  1265. * de phase si besoin, 2) MFR = 63, elements XFEM traites par RIGIXR
  1266.  
  1267. *-----------------------------------------------------------------------
  1268. *- 2.4 - Calcul de la matrice tangente selon le type d'element
  1269. *-----------------------------------------------------------------------
  1270. *
  1271. * 20 elements par ligne du GOTO
  1272. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,12,99, 4, 4, 4, 4,12,12,99,
  1273. 1 99,22, 4, 4, 4, 4,27,28,29,30,99,99,99,99,35,35,35,35,35,35,
  1274. 2 27,42,43,27,42,46,12,35,27,30,99,99,35,35,12,27,99,99,99,99,
  1275. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99,99,99,99,35,35,
  1276. 4 35,35,35,84,85,86,42,42,99,99,99,42,27,12,46,42,42,42,99,99,
  1277. 5 99,99,99,99,99,99,99,35,35,35,35,35,35,35,35,35,35,35,35,35,
  1278. 6 35,35,42,42,42,42,42,99,99,99,99,99,99,99,99,99,99,99,99,99,
  1279. 7 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,42,99,99,99,
  1280. 8 99,99,99,99,99,99,99,42,42,42,42,42, 4, 4, 4, 4, 4, 4, 4, 4,
  1281. 9 4, 4, 4, 4,99,99,99,99,99,99,99,99, 4, 4,99,99,99,99,99,99)
  1282. & ,MELE
  1283. IF (MELE.EQ.258.OR.MELE.EQ.260) GOTO 42
  1284. * Erreur : Element fini non encore implemente
  1285. 99 CONTINUE
  1286. KERRE=86
  1287. MOTERR(1:4)=NOMTP(MELE)
  1288. MOTERR(5:12)='KTANGA '
  1289. GOTO 510
  1290. *-----------------------------------------------------------------------
  1291. *-> Elements MASSIFs
  1292. *-----------------------------------------------------------------------
  1293. 4 CONTINUE
  1294. NBNO=NBNN
  1295. NBBB=NBNN
  1296. SEGINI,WRK1,WRK2
  1297. IF (BMATE) THEN
  1298. SEGINI,WTRAV
  1299. NLG=NUMGEO(MELE)
  1300. ENDIF
  1301. IF (MAPL.EQ.5 .OR. MAPL.EQ.54) CALL ZDANUL(TRAC,LTRAC)
  1302. IF (MAPL.EQ.54) SEGINI,WRK5
  1303. * Preparation a la recuperation de l'epaisseur
  1304. MVALEP=0
  1305. DIM3=1.D0
  1306. IF (IFOUR.EQ.-2) THEN
  1307. IF (IVACAR.NE.0) THEN
  1308. MPTVAL=IVACAR
  1309. MVALEP=IVAL(1)
  1310. IF (MVALEP.GT.0) THEN
  1311. MELVAL=MVALEP
  1312. NELEP=VELCHE(/2)
  1313. NPGEP=VELCHE(/1)
  1314. ENDIF
  1315. ENDIF
  1316. ENDIF
  1317. * Boucle sur les elements de la sous-zone ISOU
  1318. DO 3004 IB=1,NBELEM
  1319. * Recuperation des coordonnees des noeuds de l'element IB
  1320. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1321. * Calcul de la matrice de changement de repere (materiau a "tropie")
  1322. IF (BMATE) THEN
  1323. CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  1324. MINTE2=IPMIN2
  1325. SEGACT,MINTE2
  1326. NBSH=MINTE2.SHPTOT(/2)
  1327. CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  1328. SEGDES,MINTE2
  1329. IF (NBSH.EQ.-1) THEN
  1330. KERRE=525
  1331. GOTO 8004
  1332. ENDIF
  1333. ENDIF
  1334. * Mise a zero de la matrice de rigidite elementaire (IB)
  1335. CALL ZERO(REL,LRE,LRE)
  1336. * Cas des elements incompressibles : termes de la matrice B-BARRE
  1337. IF (MFR.EQ.31) THEN
  1338. CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU,
  1339. & QSIGAU,ETAGAU,DZEGAU,NSTRS,
  1340. & LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
  1341. ENDIF
  1342. * Boucle sur les points de Gauss de l'element IB
  1343. ISDJC=0
  1344. DO 4004 IGAU=1,NBPGAU
  1345. * Recuperation de l'epaisseur si donnee
  1346. IF (MVALEP.GT.0) THEN
  1347. MELVAL=MVALEP
  1348. IBMN=MIN(IB ,NELEP)
  1349. IGMN=MIN(IGAU,NPGEP)
  1350. DIM3=VELCHE(IGMN,IBMN)
  1351. ENDIF
  1352. * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU
  1353. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  1354. & MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,
  1355. & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1356. IF (DJAC.EQ.0.) THEN
  1357. KERRE=259
  1358. INTERR(1)=IB
  1359. GOTO 8004
  1360. ENDIF
  1361. IF (DJAC.LT.0.) ISDJC=ISDJC+1
  1362. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1363. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  1364. IF (MFR.EQ.31) THEN
  1365. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  1366. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  1367. ENDIF
  1368.  
  1369. IRET=0
  1370. * Recuperation des proprietes materielles utiles selon le modele
  1371. MPTVAL=IVAMAT
  1372. IF (MAPL.EQ.5) THEN
  1373. MELVAL=IVAL(1)
  1374. IBMN=MIN(IB ,VELCHE(/2))
  1375. IGMN=MIN(IGAU,VELCHE(/1))
  1376. YYYY=VELCHE(IGMN,IBMN)
  1377. MELVAL=IVAL(3)
  1378. IBMN=MIN(IB ,IELCHE(/2))
  1379. IGMN=MIN(IGAU,IELCHE(/1))
  1380. IMMM=IELCHE(IGMN,IBMN)
  1381. CALL COTRA1(IMMM,YYYY,LTRAC,TRAC,NTRAC,KERRE)
  1382. ELSE IF (MAPL.EQ.54) THEN
  1383. MELVAL=IVAL(12)
  1384. IBMN=MIN(IB ,IELCHE(/2))
  1385. IGMN=MIN(IGAU,IELCHE(/1))
  1386. ITREV=IELCHE(IGMN,IBMN)
  1387. MELVAL=IVAL(13)
  1388. IBMN=MIN(IB ,IELCHE(/2))
  1389. IGMN=MIN(IGAU,IELCHE(/1))
  1390. ICOEV=IELCHE(IGMN,IBMN)
  1391. IPOS1=1
  1392. CALL COTRAB(ITREV,TRAC,LTRAC,IPOS1,0,NPOINT,KERRE)
  1393. IF (KERRE.NE.0) THEN
  1394. INTERR(1)=IB
  1395. INTERR(2)=IGAU
  1396. MOTERR(1:4)=NOMTP(MELE)
  1397. GOTO 8004
  1398. ENDIF
  1399. NTRAC1=NPOINT/2
  1400. IPOS2=IPOS1+NPOINT
  1401. CALL COTRAB(ICOEV,TRAC,LTRAC,IPOS2,0,NPOINT,KERRE)
  1402. NTRAC2=NPOINT/2
  1403. IRET=WRK5
  1404. ENDIF
  1405. IF (KERRE.NE.0) THEN
  1406. INTERR(1)=IB
  1407. INTERR(2)=IGAU
  1408. MOTERR(1:4)=NOMTP(MELE)
  1409. GOTO 8004
  1410. ENDIF
  1411. IF (BMATE) IRET=WTRAV
  1412. * Contribution du pt de Gauss IGAU a la matrice tangente elementaire
  1413. CALL DOHOT1(IVAMAT,NMATT,IVACON,NSTRS,IVARI,NVART,TRAC,
  1414. & LTRAC,IGAU,IB,MATE,MAPL,XPREC,DTPS,IFOUR,
  1415. & LHOOK,DDHOOK,IRET)
  1416. IF (IRET.NE.1) THEN
  1417. IF (IRET.EQ.-1) THEN
  1418. KERRE=275
  1419. INTERR(1)=IB
  1420. INTERR(2)=IGAU
  1421. MOTERR(1:4)=NOMTP(MELE)
  1422. C* ELSE IF (IRET.EQ.0) THEN
  1423. ELSE
  1424. KERRE=328
  1425. INTERR(1)=IFOUR
  1426. MOTERR(1:8)=NOMAT(MATE)
  1427. MOTERR(9:12)=NOMAC(MAPL)
  1428. MOTERR(13:20)=NOMFR(MFR)
  1429. ENDIF
  1430. GOTO 8004
  1431. ENDIF
  1432. IF (IRIGE7.EQ.2) THEN
  1433. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1434. ELSE
  1435. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1436. ENDIF
  1437. 4004 CONTINUE
  1438. * Fin de la boucle sur les points de Gauss
  1439. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1440. KERRE=195
  1441. INTERR(1)=IB
  1442. GOTO 8004
  1443. ENDIF
  1444. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  1445. IF (IRIGE7.EQ.2)THEN
  1446. CALL REMPMS(REL,LRE,RE(1,1,IB))
  1447. ELSE
  1448. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1449. ENDIF
  1450. 3004 CONTINUE
  1451. * Fin de la boucle sur les elements
  1452. * Etiquette de gestion des erreurs
  1453. 8004 CONTINUE
  1454. * Menage local
  1455. SEGSUP,WRK1,WRK2
  1456. IF (MAPL.EQ.54) SEGSUP,WRK5
  1457. IF (BMATE) SEGSUP,WTRAV
  1458. GOTO 510
  1459. *-----------------------------------------------------------------------
  1460. *-> Elements de raccord liquide-solide :
  1461. * RAC2 LIA3 LIA4 RACO LICO LIC4 (MELE = 12 18 19 47 55 94)
  1462. * => Elements SANS RIGIDITE (elastique & tangente)
  1463. *-----------------------------------------------------------------------
  1464. 12 CONTINUE
  1465. C Les matrices elementaires sont nulles et ont ete mises a zero lors de
  1466. C l'initialisation du segment XMATRI !
  1467. GOTO 510
  1468. *-----------------------------------------------------------------------
  1469. *-> Element de type "Relations de conformites" (MELE=22)
  1470. * Matrice TANGENTE = Matrice de RIGIDITE (ELASTIQUE) (cf. RIGI1)
  1471. *-----------------------------------------------------------------------
  1472. 22 CONTINUE
  1473. IF (ITYPEL.NE.22) THEN
  1474. KERRE=977
  1475. GOTO 510
  1476. ENDIF
  1477. CALL RIGSUR(ISOU ,IPMATR, IMODEL)
  1478. GOTO 510
  1479. *-----------------------------------------------------------------------
  1480. *-> Element de type "Relations de conformites " (MELE=259)
  1481. * Matrice TANGENTE = Matrice de RIGIDITE (ELASTIQUE) (cf. RIGI1)
  1482. *-----------------------------------------------------------------------
  1483. 259 CONTINUE
  1484. IF (ITYPEL.NE.259) THEN
  1485. KERRE=977
  1486. GOTO 510
  1487. ENDIF
  1488. CALL RIGSUR(ISOU ,IPMATR, IMODEL)
  1489. * Cas particulier si formulation X-FEM
  1490. IF (IMODEL.INFELE(13).EQ.63) then
  1491. CALL RIGSUX(ISOU ,IPMATR, IMODEL)
  1492. ENDIF
  1493.  
  1494. GOTO 510
  1495. *-----------------------------------------------------------------------
  1496. *-> Elements COQ3 COQ8 COQ2 COQ4 COQ6 DST (MELE = 27 41 44 49 56 93)
  1497. *-> Cas particulier : DKT elastique (MELE = 28 avec MAPL = 0)
  1498. * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI3)
  1499. *-----------------------------------------------------------------------
  1500. 27 CONTINUE
  1501. C Coque integree ou non ?
  1502. NPINT=0
  1503. IF (INFMOD(/1).NE.0) NPINT=INFMOD(1)
  1504. MPTVAL=IVAMAT
  1505. NBGMAT = 0
  1506. NELMAT = 0
  1507. IF (CMATE.EQ.'SECTION') THEN
  1508. DO i=1,IVAL(/1)
  1509. IF (IVAL(i).NE.0)THEN
  1510. MELVAL=IVAL(i)
  1511. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1512. NELMAT=MAX(NELMAT,IELCHE(/2))
  1513. ENDIF
  1514. ENDDO
  1515. ELSE
  1516. DO i=1,IVAL(/1)
  1517. IF (IVAL(i).NE.0) THEN
  1518. MELVAL=IVAL(i)
  1519. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1520. NELMAT=MAX(NELMAT,VELCHE(/2))
  1521. ENDIF
  1522. ENDDO
  1523. ENDIF
  1524. CALL RIGI3(MATE,MELE,IPMAIL,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS,
  1525. & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,
  1526. & NMATT,LW,NPINT,IPMATR,IIPDPG)
  1527. IF (IERR.NE.0) KERRE=-ABS(IERR)
  1528. GOTO 510
  1529. *-----------------------------------------------------------------------
  1530. *-> Element DKT (MELE = 28)
  1531. *-----------------------------------------------------------------------
  1532. 28 CONTINUE
  1533. IF (MAPL.EQ.0) GOTO 27
  1534. NBNO=NBNN
  1535. NBBB=NBNN
  1536. SEGINI,WRK1,WRK2,WRK4
  1537. IF (MAPL.EQ.5) CALL ZDANUL(TRAC,LTRAC)
  1538. * Preparation a la recuperation de caracteristiques geometriques
  1539. MPTVAL=IVACAR
  1540. EXCEN=0.D0
  1541. MVALEX=IVAL(2)
  1542. IF (MVALEX.GT.0) THEN
  1543. MELVAL=MVALEX
  1544. NELEX=VELCHE(/2)
  1545. NPGEX=VELCHE(/1)
  1546. ENDIF
  1547. CALFA=0.666666666666666666666666666666666666666666666D0
  1548. MVALCA=IVAL(NCART)
  1549. IF (MVALCA.GT.0) THEN
  1550. MELVAL=MVALCA
  1551. NELCA=VELCHE(/2)
  1552. NPGCA=VELCHE(/1)
  1553. ENDIF
  1554. * Boucle sur les elements de la sous-zone ISOU
  1555. DO 3028 IB=1,NBELEM
  1556. * Recuperation des coordonnees des noeuds de l'element IB
  1557. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1558. * Passage dans le repere local de l'element
  1559. CALL VPAST(XE,BPSS)
  1560. CALL VCORLC(XE,XEL,BPSS)
  1561. * Mise a zero de la matrice de rigidite elementaire (IB)
  1562. CALL ZERO(REL,LRE,LRE)
  1563. * Boucle sur les points de Gauss de l'element IB
  1564. DO 4028 IGAU=1,NBPGAU
  1565. * Recuperation des caracteristiques geometriques
  1566. MPTVAL=IVACAR
  1567. MELVAL=IVAL(1)
  1568. IBMN=MIN(IB ,VELCHE(/2))
  1569. IGMN=MIN(IGAU,VELCHE(/1))
  1570. EPAIST=VELCHE(IGMN,IBMN)
  1571. IF (MVALEX.GT.0) THEN
  1572. MELVAL=MVALEX
  1573. IBMN=MIN(IB ,NELEX)
  1574. IGMN=MIN(IGAU,NPGEX)
  1575. EXCEN=VELCHE(IGMN,IBMN)
  1576. ENDIF
  1577. IF (MVALCA.GT.0) THEN
  1578. MELVAL=MVALCA
  1579. IBMN=MIN(IB ,NELCA)
  1580. IGMN=MIN(IGAU,NPGCA)
  1581. CALFA=VELCHE(IGMN,IBMN)
  1582. ENDIF
  1583. * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU
  1584. CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  1585. & MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL,
  1586. & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1587. DJAC=DJAC*POIGAU(IGAU)
  1588. * Modification de la matrice B en cas d'excentrement non nul
  1589. IF (ABS(EXCEN).GT.0.) THEN
  1590. DO i=1,3
  1591. k=i+3
  1592. DO j=1,LRE
  1593. BGENE(i,j)=BGENE(i,j)+EXCEN*BGENE(k,j)
  1594. ENDDO
  1595. ENDDO
  1596. ENDIF
  1597. * Recuperation des proprietes materielles utiles selon le modele
  1598. IF (MAPL.EQ.5) THEN
  1599. MPTVAL=IVAMAT
  1600. MELVAL=IVAL(1)
  1601. IBMN=MIN(IB ,VELCHE(/2))
  1602. IGMN=MIN(IGAU,VELCHE(/1))
  1603. YYYY=VELCHE(IGMN,IBMN)
  1604. MELVAL=IVAL(3)
  1605. IBMN=MIN(IB ,IELCHE(/2))
  1606. IGMN=MIN(IGAU,IELCHE(/1))
  1607. IMMM=IELCHE(IGMN,IBMN)
  1608. CALL COTRA1(IMMM,YYYY,LTRAC,TRAC,NTRAC,KERRE)
  1609. IF (KERRE.NE.0) THEN
  1610. INTERR(1)=IB
  1611. INTERR(2)=IGAU
  1612. MOTERR(1:4)=NOMTP(MELE)
  1613. GOTO 8028
  1614. ENDIF
  1615. ENDIF
  1616. * DOHOT3 se chargera de convertir les efforts generalises (IVACON)
  1617. * et les variables internes generalisees (IVARI) en contraintes et
  1618. * variables internes "locales"
  1619. * Contribution du pt de Gauss IGAU a la matrice tangente elementaire
  1620. CALL DOHOT3(IVAMAT,NMATT,IVACON,NSTRS,IVARI,NVART,
  1621. & TRAC,LTRAC,CALFA,EPAIST,IGAU,IB,MATE,MAPL,
  1622. & XPREC,DTPS,IFOUR,LHOOK,DDHOOK,IRET)
  1623. IF (IRET.NE.1) THEN
  1624. IF (IRET.EQ.-1) THEN
  1625. KERRE=275
  1626. INTERR(1)=IB
  1627. INTERR(2)=IGAU
  1628. MOTERR(1:4)=NOMTP(MELE)
  1629. C* ELSE IF (IRET.EQ.0) THEN
  1630. ELSE
  1631. KERRE=328
  1632. INTERR(1)=IFOUR
  1633. MOTERR(1:8)=NOMAT(MATE)
  1634. MOTERR(9:12)=NOMAC(MAPL)
  1635. MOTERR(13:20)=NOMFR(MFR)
  1636. ENDIF
  1637. GOTO 8028
  1638. ENDIF
  1639. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1640. 4028 CONTINUE
  1641. * Fin de la boucle sur les points de Gauss
  1642. * Calcul de la matrice tangente elementaire (IB)
  1643. REL( 6, 6)=REL(5,5)*1.D-7
  1644. REL(12,12)=REL(6,6)
  1645. REL(18,18)=REL(6,6)
  1646. CALL TRANSK(REL,BPSS,LRE,3,1)
  1647. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  1648. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1649. 3028 CONTINUE
  1650. * Fin de la boucle sur les elements
  1651. * Etiquette de gestion des erreurs
  1652. 8028 CONTINUE
  1653. * Menage local
  1654. SEGSUP,WRK1,WRK2,WRK4
  1655. GOTO 510
  1656. *-----------------------------------------------------------------------
  1657. *-> Element POUTre (MELE=29)
  1658. *-> Cas particulier : Element TIMO avec materiau ISOTROPE (MELE=84)
  1659. *-----------------------------------------------------------------------
  1660. 29 CONTINUE
  1661. NBBB=NBNN
  1662. SEGINI,WRK1,WRK3
  1663. * Boucle sur les elements de la sous-zone ISOU
  1664. DO 3029 IB=1,NBELEM
  1665. * Recuperation des coordonnees des noeuds de l'element IB
  1666. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1667. * Recuperation des caracteristiques geometriques (stockees dans WORK)
  1668. MPTVAL=IVACAR
  1669. DO IC=1,NCART-1
  1670. r_z=0.
  1671. IF (IVAL(IC).NE.0) THEN
  1672. MELVAL=IVAL(IC)
  1673. IBMN=MIN(IB,VELCHE(/2))
  1674. DO IGAU=1,NBNN
  1675. IGMN=MIN(IGAU,VELCHE(/1))
  1676. r_z=r_z+VELCHE(IGMN,IBMN)
  1677. ENDDO
  1678. r_z=r_z/NBNN
  1679. ENDIF
  1680. WORK(IC)=r_z
  1681. ENDDO
  1682. IF (IVECT.EQ.1) THEN
  1683. IF (IVAL(NCART).NE.0) THEN
  1684. MELVAL=IVAL(NCART)
  1685. IBMN=MIN(IB,IELCHE(/2))
  1686. IREF=(IELCHE(1,IBMN)-1)*(IDIM+1)
  1687. DO i=1,IDIM
  1688. WORK(NCART+i-1)=XCOOR(IREF+i)
  1689. ENDDO
  1690. ELSE
  1691. DO i=NCART,NCART+IDIM-1
  1692. WORK(i)=0.D0
  1693. ENDDO
  1694. ENDIF
  1695. ELSE
  1696. WORK(NCART)=0.
  1697. ENDIF
  1698. * Recuperation des caracteristiques elastiques (stockees dans WORK)
  1699. MPTVAL=IVAMAT
  1700. MELVAL=IVAL(1)
  1701. IBMN=MIN(IB ,VELCHE(/2))
  1702. YOUNG=VELCHE(1,IBMN)
  1703. MELVAL=IVAL(2)
  1704. IBMN=MIN(IB ,VELCHE(/2))
  1705. XNU=VELCHE(1,IBMN)
  1706. CISAIL=0.5*YOUNG/(1.+XNU)
  1707. IF (BPLAN) THEN
  1708. WORK(4)=YOUNG
  1709. WORK(5)=CISAIL
  1710. ELSE
  1711. WORK(10)=YOUNG
  1712. WORK(11)=CISAIL
  1713. ENDIF
  1714. * Modification de caracteristiques (INRY ou SECZ) selon les modeles
  1715. MPTVAL=IVARI
  1716. IF (MAPL.EQ.57.OR.MAPL.EQ.59) THEN
  1717. MELVAL=IVAL(2)
  1718. IBMN=MIN(IB,VELCHE(/2))
  1719. WORK(2)=VELCHE(1,IBMN)/YOUNG
  1720. ELSE IF(MAPL.EQ.58.OR.MAPL.EQ.60) THEN
  1721. MELVAL=IVAL(2)
  1722. IBMN=MIN(IB,VELCHE(/2))
  1723. WORK(6)=VELCHE(1,IBMN)/CISAIL
  1724. ENDIF
  1725. * Calcul de la rigidite elementaire tangente (IB)
  1726. IF (MELE.EQ.84) THEN
  1727. IF (BPLAN) THEN
  1728. CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),IRET)
  1729. ELSE
  1730. CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),IRET)
  1731. ENDIF
  1732. ELSE
  1733. IF (BPLAN) THEN
  1734. CALL POURI2(REL,LRE,WORK,XE,WORK(12),IRET)
  1735. ELSE
  1736. CALL POURIG(REL,LRE,WORK,XE,WORK(12),IRET)
  1737. ENDIF
  1738. ENDIF
  1739. IF (IRET.NE.0) THEN
  1740. IF (IRET.EQ.1) KERRE=128
  1741. IF (IRET.EQ.2) KERRE=138
  1742. INTERR(1)=ISOUS
  1743. INTERR(2)=IB
  1744. GOTO 8029
  1745. ENDIF
  1746. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)
  1747. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1748. 3029 CONTINUE
  1749. * Fin de la boucle sur les elements
  1750. * Etiquette de gestion des erreurs
  1751. 8029 CONTINUE
  1752. * Menage local
  1753. SEGSUP,WRK1,WRK3
  1754. GOTO 510
  1755. *-----------------------------------------------------------------------
  1756. *-> Elements linespring LISP et LISM en nonlineaire (MELE = 30 50)
  1757. *-----------------------------------------------------------------------
  1758. 30 CONTINUE
  1759. IF (MAPL.EQ.0) GOTO 42
  1760. NBBB=NBNN
  1761. SEGINI,WRK1,WRK3
  1762. * Boucle sur les elements de la sous-zone ISOU
  1763. DO 3030 IB=1,NBELEM
  1764. * Recuperation des coordonnees des noeuds de l'element IB
  1765. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1766. IE=1
  1767. * Recuperation des proprietes materielles (stockees dans WORK)
  1768. IE1=IE
  1769. MPTVAL=IVAMAT
  1770. DO IC=1,NBPGAU
  1771. DO i=1,2
  1772. MELVAL=IVAL(i)
  1773. IGMN=MIN(IC,VELCHE(/1))
  1774. IBMN=MIN(IB,VELCHE(/2))
  1775. WORK(IE)=VELCHE(IGMN,IBMN)
  1776. IE=IE+1
  1777. ENDDO
  1778. DO i=3,4
  1779. WORK(IE)=0.D0
  1780. IE=IE+1
  1781. ENDDO
  1782. MELVAL=IVAL(3)
  1783. IGMN=MIN(IC,VELCHE(/1))
  1784. IBMN=MIN(IB,VELCHE(/2))
  1785. WORK(IE)=VELCHE(IGMN,IBMN)
  1786. IE=IE+1
  1787. ENDDO
  1788. * Recuperation des contraintes (stockees dans WORK)
  1789. IE2=IE
  1790. MPTVAL=IVACON
  1791. DO IC=1,NBGS
  1792. DO i=1,NSTRS
  1793. MELVAL=IVAL(i)
  1794. IGMN=MIN(IC,VELCHE(/1))
  1795. IBMN=MIN(IB ,VELCHE(/2))
  1796. WORK(IE)=VELCHE(IGMN,IBMN)
  1797. IE=IE+1
  1798. ENDDO
  1799. ENDDO
  1800. * Recuperation des caracteristiques geometriques (stockees dans WORK)
  1801. IE3=IE
  1802. MPTVAL=IVACAR
  1803. DO IC=1,NBPGAU
  1804. DO i=1,NCART
  1805. MELVAL=IVAL(i)
  1806. IGMN=MIN(IC,VELCHE(/1))
  1807. IBMN=MIN(IB,VELCHE(/2))
  1808. WORK(IE)=VELCHE(IGMN,IBMN)
  1809. IE=IE+1
  1810. ENDDO
  1811. ENDDO
  1812. * Recuperation des variables internes (stockees dans WORK)
  1813. IE4=IE
  1814. MPTVAL=IVARI
  1815. DO IC=1,NBGS
  1816. DO i=1,NVART
  1817. MELVAL=IVAL(i)
  1818. IGMN=MIN(IC,VELCHE(/1))
  1819. IBMN=MIN(IB,VELCHE(/2))
  1820. WORK(IE)=VELCHE(IGMN,IBMN)
  1821. IE=IE+1
  1822. ENDDO
  1823. ENDDO
  1824. IE5=IE+1
  1825. * Calcul de la rigidite elementaire tangente (IB)
  1826. CALL LISPKT(XE,WORK(IE1),WORK(IE2),WORK(IE3),WORK(IE4),NSTRS,
  1827. & NBGS,NBPGAU,MELE,XPREC,WORK(IE5),REL,I70,I157,
  1828. & I158,IRET,KERRE)
  1829. IF (IRET.EQ.-1.OR.KERRE.NE.0) THEN
  1830. KERRE=270
  1831. IF (IRET.EQ.-1) KERRE=275
  1832. INTERR(1)=IB
  1833. INTERR(2)=1
  1834. MOTERR(1:4)=NOMTP(MELE)
  1835. GOTO 8030
  1836. ENDIF
  1837. IF (I158.EQ.1) THEN
  1838. KERRE=158
  1839. INTERR(1)=IB
  1840. GOTO 8030
  1841. ENDIF
  1842. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  1843. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1844. 3030 CONTINUE
  1845. * Fin de la boucle sur les elements
  1846. * Etiquette de gestion des erreurs
  1847. 8030 CONTINUE
  1848. * Menage local
  1849. SEGSUP,WRK1,WRK3
  1850. GOTO 510
  1851. *-----------------------------------------------------------------------
  1852. *-> Elements liquide LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 (MELE = 35 a 40)
  1853. * Elements de surface libre LSU2 LSU3 LSU4 (MELE = 48 53 54)
  1854. * Elements poreux TRIP QUAP CUBP TETP PRIP (MELE = 79 a 83)
  1855. * Elements joints poreux JOP3 JOP6 JOP8 (MELE = 108 a 110)
  1856. * Elements massifs polygonaux POLY (MELE = 111 a 122)
  1857. * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI2)
  1858. *-----------------------------------------------------------------------
  1859. 35 CONTINUE
  1860. NCAR1 = NCART + 1
  1861. MPTVAL=IVAMAT
  1862. NBGMAT = 0
  1863. NELMAT = 0
  1864. IF (CMATE.EQ.'SECTION') THEN
  1865. DO i=1,IVAL(/1)
  1866. IF (IVAL(i).NE.0) THEN
  1867. MELVAL=IVAL(i)
  1868. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1869. NELMAT=MAX(NELMAT,IELCHE(/2))
  1870. ENDIF
  1871. ENDDO
  1872. ELSE
  1873. DO i=1,IVAL(/1)
  1874. IF (IVAL(i).NE.0) THEN
  1875. MELVAL=IVAL(i)
  1876. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1877. NELMAT=MAX(NELMAT,VELCHE(/2))
  1878. ENDIF
  1879. ENDDO
  1880. ENDIF
  1881. CALL RIGI2 (MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT,
  1882. & IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,NMATT,IPORE,
  1883. & NDDL,IPMATR,IIPDPG,NCAR1)
  1884. IF (IERR.NE.0) KERRE=-ABS(IERR)
  1885. GOTO 510
  1886. *-----------------------------------------------------------------------
  1887. *-> Elements TUYA POI1 JOT3 JOI4 TRIH TUYO (MELE = 42 45 87 88 92 96)
  1888. * LSE2 LITU BAR3 BAEX LIA2 QUAH CUBH (MELE = 97 98 123 a 127)
  1889. * TRH6 JCT3 JCI4 JGI2 JGT3 JGI4 (MELE = 157 168 a 172)
  1890. * CIFL SURE?? SHB8 (MELE = 258 259? 260)
  1891. *-> Cas particuliers : LISP & LISM en elasticite (MELE= 30 50 & MAPL=0)
  1892. * TUFI en elasticite (MELE=43 & MAPL=0)
  1893. * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI4)
  1894. *-----------------------------------------------------------------------
  1895. 42 CONTINUE
  1896. MPTVAL=IVAMAT
  1897. NBGMAT = 0
  1898. NELMAT = 0
  1899. IF (CMATE.EQ.'SECTION') THEN
  1900. DO i=1,IVAL(/1)
  1901. IF (IVAL(i).NE.0)THEN
  1902. MELVAL=IVAL(i)
  1903. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1904. NELMAT=MAX(NELMAT,IELCHE(/2))
  1905. ENDIF
  1906. ENDDO
  1907. ELSE
  1908. DO i=1,IVAL(/1)
  1909. IF (IVAL(i).NE.0)THEN
  1910. MELVAL=IVAL(i)
  1911. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1912. NELMAT=MAX(NELMAT,VELCHE(/2))
  1913. ENDIF
  1914. ENDDO
  1915. ENDIF
  1916. CALL RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  1917. & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,1,
  1918. & LHOOK,NMATT,NCART,ISOUS,LW,IPORE,IPMATR,IIPDPG)
  1919. IF (IERR.NE.0) KERRE=-ABS(IERR)
  1920. GOTO 510
  1921. *-----------------------------------------------------------------------
  1922. *-> Element TUFI en non lineaire (MELE=43)
  1923. *-----------------------------------------------------------------------
  1924. 43 CONTINUE
  1925. IF (MAPL.EQ.0) GOTO 42
  1926. C* Temporaire : si SIGF n'est pas definie, on utilise la matrice elastique
  1927. MPTVAL=IVAMAT
  1928. IF (IVAL(3).EQ.0) GOTO 42
  1929. NBBB=NBNN
  1930. SEGINI,WRK1,WRK3
  1931. * Boucle sur les elements de la sous-zone ISOU
  1932. DO 3043 IB=1,NBELEM
  1933. * Recuperation des proprietes materielles (stockees dans WORK)
  1934. IE =1
  1935. IE1=IE
  1936. MPTVAL=IVAMAT
  1937. DO IC=1,NBPGAU
  1938. DO i=1,2
  1939. MELVAL=IVAL(i)
  1940. IGMN=MIN(IC,VELCHE(/1))
  1941. IBMN=MIN(IB,VELCHE(/2))
  1942. WORK(IE)=VELCHE(IGMN,IBMN)
  1943. IE=IE+1
  1944. ENDDO
  1945. DO i=3,4
  1946. WORK(IE)=0.D0
  1947. IE=IE+1
  1948. ENDDO
  1949. MELVAL=IVAL(3)
  1950. IF (MELVAL.NE.0) THEN
  1951. IGMN=MIN(IC,VELCHE(/1))
  1952. IBMN=MIN(IB,VELCHE(/2))
  1953. WORK(IE)=VELCHE(IGMN,IBMN)
  1954. ELSE
  1955. WORK(IE)=0.D0
  1956. ENDIF
  1957. IE=IE+1
  1958. DO i=6,7
  1959. WORK(IE)=0.D0
  1960. IE=IE+1
  1961. ENDDO
  1962. ENDDO
  1963. * Recuperation des contraintes (stockees dans WORK)
  1964. IE2=IE
  1965. MPTVAL=IVACON
  1966. DO IC=1,NBGS
  1967. DO i=1,NSTRS
  1968. MELVAL=IVAL(i)
  1969. IGMN=MIN(IC,VELCHE(/1))
  1970. IBMN=MIN(IB,VELCHE(/2))
  1971. WORK(IE)=VELCHE(IGMN,IBMN)
  1972. IE=IE+1
  1973. ENDDO
  1974. ENDDO
  1975. * Recuperation des caracteristiques geometriques (stockees dans WORK)
  1976. IE3=IE
  1977. MPTVAL=IVACAR
  1978. DO IC=1,NBPGAU
  1979. DO i=1,8
  1980. MELVAL=IVAL(i)
  1981. IGMN=MIN(IC,VELCHE(/1))
  1982. IBMN=MIN(IB,VELCHE(/2))
  1983. WORK(IE)=VELCHE(IGMN,IBMN)
  1984. IE=IE+1
  1985. ENDDO
  1986. WORK(IE)=0.D0
  1987. IE=IE+1
  1988. ENDDO
  1989. * Recuperation des variables internes (stockees dans WORK)
  1990. IE4=IE
  1991. MPTVAL=IVARI
  1992. DO IC=1,NBGS
  1993. DO i=1,NVART
  1994. MELVAL=IVAL(i)
  1995. IGMN=MIN(IC,VELCHE(/1))
  1996. IBMN=MIN(IB,VELCHE(/2))
  1997. WORK(IE)=VELCHE(IGMN,IBMN)
  1998. IE=IE+1
  1999. ENDDO
  2000. ENDDO
  2001. IE5=IE+1
  2002. * Calcul de la rigidite elementaire tangente (IB)
  2003. CALL TUFIKT(WORK(IE1),WORK(IE2),WORK(IE3),WORK(IE4),REL,XPREC,
  2004. & IRET)
  2005. IF (IRET.NE.0) THEN
  2006. INTERR(1)=ISOUS
  2007. INTERR(2)=IB
  2008. IF (IRET.EQ.1) KERRE=137
  2009. IF (IRET.EQ.2) KERRE=123
  2010. IF (IRET.EQ.3) KERRE=266
  2011. IF (IRET.EQ.4) THEN
  2012. KERRE=275
  2013. INTERR(1)=IB
  2014. INTERR(2)=1
  2015. MOTERR(1:4)=NOMTP(MELE)
  2016. ENDIF
  2017. GOTO 8043
  2018. ENDIF
  2019. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  2020. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2021. 3043 CONTINUE
  2022. * Fin de la boucle sur les elements
  2023. * Etiquette de gestion des erreurs
  2024. 8043 CONTINUE
  2025. * Menage local
  2026. SEGSUP,WRK1,WRK3
  2027. GOTO 510
  2028. *-----------------------------------------------------------------------
  2029. *-> Elements BARRe et CERCe (MELE = 46 95)
  2030. *-----------------------------------------------------------------------
  2031. 46 CONTINUE
  2032. IF (MELE.EQ.95.AND.(IFOUR.NE.0.AND.IFOUR.NE.1)) GOTO 99
  2033. NBBB=NBNN
  2034. SEGINI,WRK1,WRK3
  2035. MPTVAL=IVACAR
  2036. MELVAL=IVAL(1)
  2037. NELCAR=VELCHE(/2)
  2038. MELCAR=IVAL(1)
  2039. * Boucle sur les elements de la sous-zone ISOU
  2040. DO 3046 IB=1,NBELEM
  2041. * Recuperation des coordonnees des noeuds de l'element IB
  2042. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2043. * Recuperation de la section de l'element IB
  2044. MELVAL=MELCAR
  2045. IBMN=MIN(IB,NELCAR)
  2046. SECT=VELCHE(1,IBMN)
  2047. * Recuperation du module tangent selon le modele utilise
  2048. MPTVAL=IVARI
  2049. IF (MAPL.EQ.93) THEN
  2050. MELVAL=IVAL(16)
  2051. IBMN=MIN(IB,VELCHE(/2))
  2052. YOUNGT=VELCHE(1,IBMN)
  2053. ELSE IF (MAPL.EQ.92) THEN
  2054. MELVAL=IVAL(6)
  2055. IBMN=MIN(IB,VELCHE(/2))
  2056. YOUNGT=VELCHE(1,IBMN)
  2057. ELSE IF (MAPL.EQ.39) THEN
  2058. MELVAL=IVAL(6)
  2059. IBMN=MIN(IB,VELCHE(/2))
  2060. YOUNGT=VELCHE(1,IBMN)
  2061. ELSE IF (MAPL.EQ.40) THEN
  2062. MELVAL=IVAL(4)
  2063. IBMN=MIN(IB,VELCHE(/2))
  2064. YOUNGT=VELCHE(1,IBMN)
  2065. ELSE IF (MAPL.EQ.0) THEN
  2066. MPTVAL=IVAMAT
  2067. MELVAL=IVAL(1)
  2068. IBMN=MIN(IB,VELCHE(/2))
  2069. YOUNGT=VELCHE(1,IBMN)
  2070. ELSE
  2071. KERRE=81
  2072. MOTERR(1:8)=CMATE
  2073. MOTERR(9:16)=NOMFR(MFR/2+1)
  2074. INTERR(1)=IFOUR
  2075. GOTO 8046
  2076. ENDIF
  2077. * Calcul de la rigidite elementaire tangente (IB)
  2078. XHOOK=YOUNGT*SECT
  2079. IF (MELE.EQ.46) THEN
  2080. CALL BARRIG(REL,LRE,XHOOK,XE,IRET)
  2081. IF (IRET.EQ.1) KERRE=128
  2082. ELSE IF (MELE.EQ.95) THEN
  2083. CALL CERRIG(REL,LRE,XHOOK,XE,IRET)
  2084. IF (IRET.EQ.1) KERRE=601
  2085. ENDIF
  2086. IF (KERRE.NE.0) THEN
  2087. INTERR(1)=ISOUS
  2088. INTERR(2)=IB
  2089. GOTO 8046
  2090. ENDIF
  2091. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  2092. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2093. 3046 CONTINUE
  2094. * Fin de la boucle sur les elements
  2095. * Etiquette de gestion des erreurs
  2096. 8046 CONTINUE
  2097. * Menage local
  2098. SEGSUP,WRK1,WRK3
  2099. GOTO 510
  2100. *-----------------------------------------------------------------------
  2101. *-> Element de poutre de TIMOschenko (MELE=84 - Formulation 'SECTION')
  2102. *-----------------------------------------------------------------------
  2103. 84 CONTINUE
  2104. IF (CMATE.EQ.'ISOTROPE') GOTO 29
  2105. * Remarque : La formulation SECTION est le seul cas prevu actuellement.
  2106. IF (CMATE.NE.'SECTION') THEN
  2107. KERRE=193
  2108. MOTERR(1:8)=NOMFR(MFR)
  2109. GOTO 510
  2110. ENDIF
  2111. NBBB=NBNN
  2112. SEGINI WRK1,WRK3
  2113. * Boucle sur les elements de la sous-zone ISOU
  2114. DO 3084 IB=1,NBELEM
  2115. * Recuperation des coordonnees des noeuds de l'element IB
  2116. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2117. * Recuperation des caracteristiques geometriques (stockees dans WORK)
  2118. * Attention : on a tenu compte du fait que NCART=1
  2119. MPTVAL=IVACAR
  2120. IF (IVAL(NCART).NE.0) THEN
  2121. MELVAL=IVAL(NCART)
  2122. IBMN=MIN(IB,IELCHE(/2))
  2123. IP=IELCHE(1,IBMN)
  2124. IREF=(IP-1)*(IDIM+1)
  2125. DO IC=1,IDIM
  2126. WORK(IC)=XCOOR(IREF+IC)
  2127. ENDDO
  2128. ELSE
  2129. DO IC=1,IDIM
  2130. WORK(IC)=0.D0
  2131. ENDDO
  2132. ENDIF
  2133. MPTVAL=IVAMAT
  2134. * Traitement dans le cas de la formulation section
  2135. C** IF (CMATE.EQ.'SECTION') THEN
  2136. * Dans le cas d'un materiau elastique, on prend les matrices de Hooke
  2137. * si elles existent dans le MCHAML des proprietes materielles
  2138. IF (MAPL.EQ.0.AND.IVAL(3).NE.0) THEN
  2139. MELVAL=IVAL(3)
  2140. IF (IB.LE.IELCHE(/2).OR.IELCHE(/1).GT.1) THEN
  2141. IBMN=MIN(IB,IELCHE(/2))
  2142. MLREEL=IELCHE(1,IBMN)
  2143. SEGACT,MLREEL
  2144. CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2145. SEGDES,MLREEL
  2146. ENDIF
  2147. ELSE
  2148. MELVAL=IVAL(1)
  2149. IBMN=MIN(IB,IELCHE(/2))
  2150. IPMOD=IELCHE(1,IBMN)
  2151. MELVAL=IVAL(2)
  2152. IBMN=MIN(IB,IELCHE(/2))
  2153. IPCAR=IELCHE(1,IBMN)
  2154. * Sinon calcul des matrices de Hooke a partir des proprietes elastiques
  2155. IF (MAPL.EQ.0) THEN
  2156. CALL FRIGIE(IPMOD,IPCAR,CRIGI,CMASS)
  2157. * Ou calcul des matrices de Hooke a partir des variables internes
  2158. ELSE
  2159. MPTVAL=IVARI
  2160. MELVAL=IVAL(2)
  2161. IBMN=MIN(IB,IELCHE(/2))
  2162. IPVAR=IELCHE(1,IBMN)
  2163. IF (IPVAR.NE.0) THEN
  2164. CALL FRIGTA(IPMOD,IPCAR,IPVAR,CRIGI)
  2165. ELSE
  2166. CALL FRIGIE(IPMOD,IPCAR,CRIGI,CMASS)
  2167. ENDIF
  2168. ENDIF
  2169. CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRET)
  2170. ENDIF
  2171. IF (BPLAN) THEN
  2172. CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,DDHOOK,IRET)
  2173. ELSE
  2174. CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,DDHOOK,IRET)
  2175. ENDIF
  2176. C** ENDIF
  2177. IF (IRET.NE.0) THEN
  2178. INTERR(1)=ISOUS
  2179. INTERR(2)=IB
  2180. IF (IRET.EQ.1) KERRE=128
  2181. IF (IRET.EQ.2) KERRE=138
  2182. GOTO 8084
  2183. ENDIF
  2184. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  2185. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2186. 3084 CONTINUE
  2187. * Fin de la boucle sur les elements
  2188. * Etiquette de gestion des erreurs
  2189. 8084 CONTINUE
  2190. * Menage local
  2191. SEGSUP,WRK1,WRK3
  2192. GOTO 510
  2193. *-----------------------------------------------------------------------
  2194. *-> Element JOI2 - Materiau ISOTROPE (MELE = 85)
  2195. *-----------------------------------------------------------------------
  2196. *OF A voir : Erreur pour joi_ama.dgibi car MAPL=47 et on passe dans
  2197. *OF DOUOTA qui ne traite que MAPL=35,56,91
  2198. 85 CONTINUE
  2199. IF (CMATE.NE.'ISOTROPE') THEN
  2200. KERRE=834
  2201. MOTERR(1:8)=CMATE
  2202. GOTO 510
  2203. ENDIF
  2204. NBNO=NBNN
  2205. NBBB=NBNN
  2206. LW=100
  2207. SEGINI,WRK1,WRK2,WRK3,WRK4
  2208. * Boucle sur les elements de la sous-zone ISOU
  2209. DO 3085 IB=1,NBELEM
  2210. * Recuperation des coordonnees des noeuds de l'element IB
  2211. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2212. * Calcul des axes locaux de l'element IB
  2213. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2214. * Mise a zero de la matrice de rigidite elementaire (IB)
  2215. CALL ZERO(REL,LRE,LRE)
  2216. * Boucle sur les points de Gauss de l'element IB
  2217. DO 4085 IGAU=1,NBPGAU
  2218. * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU
  2219. CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  2220. & BGENE,DJAC,IRET)
  2221. DJAC=DJAC*POIGAU(IGAU)
  2222. * Erreur si le jacobien est <= 0.
  2223. IF (IRET.NE.0) THEN
  2224. KERRE=612
  2225. INTERR(1)=IB
  2226. GOTO 8085
  2227. ENDIF
  2228. * Recuperation des proprietes materielles (stockees dans WORK)
  2229. IE=1
  2230. IE1=IE
  2231. MPTVAL=IVAMAT
  2232. DO i=1,NMATT
  2233. MELVAL=IVAL(i)
  2234. IBMN=MIN(IB ,VELCHE(/2))
  2235. IGMN=MIN(IGAU,VELCHE(/1))
  2236. WORK(IE)=VELCHE(IGMN,IBMN)
  2237. IE=IE+1
  2238. ENDDO
  2239. * Calcul de la matrice de Hooke tangente au point de Gauss IGAU
  2240. IF (MAPL.EQ.35.OR.MAPL.EQ.56.OR.MAPL.EQ.91) THEN
  2241. * Recuperation des contraintes (stockees dans WORK)
  2242. IE2=IE
  2243. MPTVAL=IVACON
  2244. DO i=1,NSTRS
  2245. MELVAL=IVAL(i)
  2246. IBMN=MIN(IB ,VELCHE(/2))
  2247. IGMN=MIN(IGAU,VELCHE(/1))
  2248. WORK(IE)=VELCHE(IGMN,IBMN)
  2249. IE=IE+1
  2250. ENDDO
  2251. * Recuperation des variables internes (stockees dans WORK)
  2252. IE3=IE
  2253. MPTVAL=IVARI
  2254. DO i=1,NVARI+NVARF
  2255. MELVAL=IVAL(i)
  2256. IBMN=MIN(IB ,VELCHE(/2))
  2257. IGMN=MIN(IGAU,VELCHE(/1))
  2258. WORK(IE)=VELCHE(IGMN,IBMN)
  2259. IE=IE+1
  2260. ENDDO
  2261. CALL DOUOTA(WORK(IE1),CMATE,IFOUR,MAPL,WORK(IE2),
  2262. & WORK(IE3),LHOOK,DDHOOK,IRET)
  2263. ELSE
  2264. CALL DOUO88(WORK(IE1),CMATE,IFOUR,LHOOK,DDHOOK,IRET)
  2265. ENDIF
  2266. IF (IRET.EQ.0) THEN
  2267. KERRE=81
  2268. INTERR(1)=IFOUR
  2269. MOTERR(1:8)=CMATE
  2270. MOTERR(9:16)=NOMFR(MFR/2+1)
  2271. GOTO 8085
  2272. ENDIF
  2273. * Contribution du pt de Gauss IGAU a la matrice tangente elementaire
  2274. IF (IRIGE7.EQ.2) THEN
  2275. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2276. ELSE
  2277. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2278. ENDIF
  2279. 4085 CONTINUE
  2280. * Fin de la boucle sur les points de Gauss
  2281. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  2282. IF (IRIGE7.EQ.2) THEN
  2283. CALL REMPMS(REL,LRE,RE(1,1,IB))
  2284. ELSE
  2285. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2286. ENDIF
  2287. 3085 CONTINUE
  2288. * Fin de la boucle sur les elements
  2289. * Etiquette de gestion des erreurs
  2290. 8085 CONTINUE
  2291. * Menage local
  2292. SEGSUP,WRK1,WRK2,WRK3,WRK4
  2293. GOTO 510
  2294. *-----------------------------------------------------------------------
  2295. *-> Element JOI3 - Materiau ISOTROPE (MELE = 86)
  2296. *-----------------------------------------------------------------------
  2297. 86 CONTINUE
  2298. IF (CMATE.NE.'ISOTROPE') THEN
  2299. KERRE=834
  2300. MOTERR(1:8)=CMATE
  2301. GOTO 510
  2302. ENDIF
  2303. NBNO=NBNN
  2304. NBBB=NBNN
  2305. LW=100
  2306. SEGINI,WRK1,WRK2,WRK3,WRK4
  2307. * Boucle sur les elements de la sous-zone ISOU
  2308. DO 3086 IB=1,NBELEM
  2309. * Recuperation des coordonnees des noeuds de l'element IB
  2310. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2311. * Mise a zero de la matrice de rigidite elementaire (IB)
  2312. CALL ZERO(REL,LRE,LRE)
  2313. * Boucle sur les points de Gauss de l'element IB
  2314. DO 4086 IGAU=1,NBPGAU
  2315. * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU
  2316. CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS)
  2317. CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  2318. & BGENE,DJAC,IRET)
  2319. DJAC=DJAC*POIGAU(IGAU)
  2320. * Erreur si le jacobien est <= 0.
  2321. IF (IRET.NE.0) THEN
  2322. KERRE=612
  2323. INTERR(1)=IB
  2324. CALL ERREUR(612)
  2325. GOTO 8086
  2326. ENDIF
  2327. * Recuperation des proprietes materielles (stockees dans WORK)
  2328. IE=1
  2329. IE1=IE
  2330. MPTVAL=IVAMAT
  2331. DO i=1,NMATT
  2332. MELVAL=IVAL(i)
  2333. IBMN=MIN(IB ,VELCHE(/2))
  2334. IGMN=MIN(IGAU,VELCHE(/1))
  2335. WORK(IE)=VELCHE(IGMN,IBMN)
  2336. IE=IE+1
  2337. ENDDO
  2338. * Calcul de la matrice de Hooke tangente au point de Gauss IGAU
  2339. IF (MAPL.EQ.35.OR.MAPL.EQ.56.OR.MAPL.EQ.91) THEN
  2340. * Recuperation des contraintes (stockees dans WORK)
  2341. IE2=IE
  2342. MPTVAL=IVACON
  2343. DO i=1,NSTRS
  2344. MELVAL=IVAL(i)
  2345. IBMN=MIN(IB ,VELCHE(/2))
  2346. IGMN=MIN(IGAU,VELCHE(/1))
  2347. WORK(IE)=VELCHE(IGMN,IBMN)
  2348. IE=IE+1
  2349. ENDDO
  2350. * Recuperation des variables internes (stockees dans WORK)
  2351. IE3=IE
  2352. MPTVAL=IVARI
  2353. DO i=1,NVARI+NVARF
  2354. MELVAL=IVAL(i)
  2355. IBMN=MIN(IB ,VELCHE(/2))
  2356. IGMN=MIN(IGAU,VELCHE(/1))
  2357. WORK(IE)=VELCHE(IGMN,IBMN)
  2358. IE=IE+1
  2359. ENDDO
  2360. CALL DOUOTA(WORK(IE1),CMATE,IFOUR,MAPL,WORK(IE2),
  2361. & WORK(IE3),LHOOK,DDHOOK,IRET)
  2362. ELSE
  2363. CALL DOUO88(WORK(IE1),CMATE,IFOUR,LHOOK,DDHOOK,IRET)
  2364. ENDIF
  2365. IF (IRET.EQ.0) THEN
  2366. KERRE=81
  2367. INTERR(1)=IFOUR
  2368. MOTERR(1:8)=CMATE
  2369. MOTERR(9:16)=NOMFR(MFR/2+1)
  2370. GOTO 8086
  2371. ENDIF
  2372. * Contribution du pt de Gauss IGAU a la matrice tangente elementaire
  2373. IF (IRIGE7.EQ.2) THEN
  2374. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2375. ELSE
  2376. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2377. ENDIF
  2378. 4086 CONTINUE
  2379. * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB))
  2380. IF (IRIGE7.EQ.2) THEN
  2381. CALL REMPMS(REL,LRE,RE(1,1,IB))
  2382. ELSE
  2383. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2384. ENDIF
  2385. 3086 CONTINUE
  2386. * Fin de la boucle sur les elements
  2387. * Etiquette de gestion des erreurs
  2388. 8086 CONTINUE
  2389. * Menage local
  2390. SEGSUP,WRK1,WRK2,WRK3,WRK4
  2391. GOTO 510
  2392. *-----------------------------------------------------------------------
  2393. * desactivation des segments propres a la zone geometrique ISOU
  2394. *-----------------------------------------------------------------------
  2395. 510 CONTINUE
  2396. IF (IPMATR.NE.0) THEN
  2397. * Symetrisation de la matrice si demandee
  2398. IF (IRIGE7.EQ.2 .AND. IKTSYM.EQ.1) THEN
  2399. LRE = RE(/1)
  2400. DO 5100 IB=1,NBELEM
  2401. DO i=1,LRE
  2402. DO j=i+1,LRE
  2403. RE(i,j,IB) = 0.5*( RE(i,j,IB)+RE(j,i,IB) )
  2404. RE(j,i,IB) = RE(i,j,IB)
  2405. ENDDO
  2406. ENDDO
  2407. 5100 CONTINUE
  2408. ENDIF
  2409. ENDIF
  2410. IF (IPDSCR.NE.0) SEGDES,DESCR
  2411. 515 CONTINUE
  2412. IF (ISUPMA.EQ.1) THEN
  2413. CALL DTMVAL(IVACAR,3)
  2414. ELSE
  2415. CALL DTMVAL(IVACAR,1)
  2416. ENDIF
  2417. IF (ISUPMA.EQ.1) THEN
  2418. CALL DTMVAL(IVAMAT,3)
  2419. ELSE
  2420. CALL DTMVAL(IVAMAT,1)
  2421. ENDIF
  2422. IF (ISUPVA.EQ.1) THEN
  2423. CALL DTMVAL(IVARI,3)
  2424. ELSE
  2425. CALL DTMVAL(IVARI,1)
  2426. ENDIF
  2427. IF (ISUPCO.EQ.1) THEN
  2428. CALL DTMVAL(IVACON,3)
  2429. ELSE
  2430. CALL DTMVAL(IVACON,1)
  2431. ENDIF
  2432. IF (lsupdp) THEN
  2433. NOMID=MODEPL
  2434. SEGSUP,NOMID
  2435. ENDIF
  2436. IF (lsupfo) THEN
  2437. NOMID=MOFORC
  2438. SEGSUP,NOMID
  2439. ENDIF
  2440. ** MELEME=IPMAIL
  2441. SEGDES,MELEME
  2442. * Mise a jour du segment MRIGID en cas de SUCCES !
  2443. IF (KERRE.EQ.0) THEN
  2444. COERIG(ISOU)=1.D0
  2445. IRIGEL(1,ISOU)=IPMAGD
  2446. IRIGEL(2,ISOU)=0
  2447. IRIGEL(3,ISOU)=IPDSCR
  2448. IRIGEL(4,ISOU)=IPMATR
  2449. IRIGEL(5,ISOU)=NIFOUR
  2450. IRIGEL(6,ISOU)=0
  2451. IRIGEL(7,ISOU)=IRIGE7*(1-IKTSYM)
  2452. xmatri.symre=irigel(7,isou)
  2453. SEGDES,XMATRI
  2454. IRIGEL(8,ISOU)=0
  2455. * Sinon en cas d'ERREUR : sortie prematuree !
  2456. ELSE
  2457. * Affichage erreur si KERRE > 0 (car KERRE<0 qd erreur deja imprimee)
  2458. IF (KERRE.GT.0) CALL ERREUR(KERRE)
  2459. IF (IPDSCR.NE.0) SEGSUP,DESCR
  2460. IF (IPMATR.NE.0) SEGSUP,XMATRI
  2461. ** IF (IPMAGD.GT.0.AND.IPMAGD.NE.IPMAIL) THEN
  2462. ** MELEME=IPMAGD
  2463. ** SEGSUP,MELEME
  2464. ** ENDIF
  2465. IF (MELE.NE.260) SEGDES,MINTE
  2466. GOTO 551
  2467. ENDIF
  2468. * Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI
  2469. 5000 CONTINUE
  2470. IF (MELE.NE.260) SEGDES,MINTE
  2471. *-----------------------------------------------------------------------
  2472. * Fin de la boucle sur les sous-zones du modele
  2473. *-----------------------------------------------------------------------
  2474. 500 CONTINUE
  2475.  
  2476. * Sortie du sous-programme
  2477. 551 CONTINUE
  2478. IF (KERRE.EQ.0) THEN
  2479. SEGDES,MRIGID
  2480. IPRIGI=MRIGID
  2481. ELSE
  2482. SEGSUP,MRIGID
  2483. IPRIGI=0
  2484. ENDIF
  2485. * Suppression du modele "deroule"
  2486. 550 CONTINUE
  2487. MMODEL = IPMODL
  2488. DO i = 1,KMODEL(/1)
  2489. IMODEL = KMODEL(i)
  2490. SEGDES,IMODEL
  2491. ENDDO
  2492. SEGSUP,MMODEL
  2493. * Desactivation des champs par element
  2494. MCHELM=IPCHE1
  2495. SEGDES,MCHELM
  2496. MCHELM=IPCHE2
  2497. SEGDES,MCHELM
  2498. MCHELM=IPCHE3
  2499. SEGDES,MCHELM
  2500.  
  2501. RETURN
  2502. END
  2503.  
  2504.  
  2505.  

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