Télécharger ktanga.eso

Retour à la liste

Numérotation des lignes :

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

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