Télécharger ktanga.eso

Retour à la liste

Numérotation des lignes :

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

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