Télécharger coml6.eso

Retour à la liste

Numérotation des lignes :

  1. C COML6 SOURCE PV 17/12/08 21:16:41 9660
  2.  
  3. SUBROUTINE COML6(iqmod,ipcon,ipinf,indeso,insupp,itruli,
  4. > wr10, IRETOU)
  5.  
  6. *--------------------------------------------------------------------
  7. * coml6 :
  8. * boucle elements et point d integration
  9. * pretraite les caracteristiques et les donnees suivant
  10. * le modele, passe a la loi locale, signale les erreurs
  11. * d integration, prepare les resultats
  12. *----------------------------------------------------------------
  13.  
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8(A-H,O-Z)
  16.  
  17. -INC CCOPTIO
  18. -INC CCGEOME
  19. -INC CCHAMP
  20.  
  21. -INC SMCHAML
  22. -INC SMELEME
  23. -INC SMCOORD
  24. -INC SMMODEL
  25. -INC SMINTE
  26. * segment deroulant le mcheml
  27. -INC DECHE
  28. SEGMENT INFO
  29. INTEGER INFELL(16)
  30. ENDSEGMENT
  31. *
  32. SEGMENT WRK2
  33. REAL*8 TRAC(LTRAC)
  34. ENDSEGMENT
  35. *
  36. SEGMENT MWRKXE
  37. REAL*8 XEL(3,NBNN)
  38. ENDSEGMENT
  39. *
  40. SEGMENT WRK3
  41. REAL*8 WORK(LW),WORK2(LW2bi)
  42. ENDSEGMENT
  43. *
  44. SEGMENT WRK6
  45. REAL*8 BB(NSTRS,NNVARI),R(NSTRS),XMU(NSTRS)
  46. REAL*8 S(NNVARI),QSI(NNVARI),DDR(NSTRS),BBS(NSTRS)
  47. REAL*8 SIGMA(NSTRS),SIGGD(NSTRS),XMULT(NSTRS),PROD(NSTRS)
  48. ENDSEGMENT
  49. *
  50. SEGMENT WRK7
  51. REAL*8 F(NCOURB,2),W(NCOURB),TRUC(NCOURB)
  52. ENDSEGMENT
  53. *
  54. SEGMENT WRK8
  55. REAL*8 DD(NSTRS,NSTRS),DDV(NSTRS,NSTRS),DDINV(NSTRS,NSTRS)
  56. REAL*8 DDINVp(NSTRS,NSTRS)
  57. ENDSEGMENT
  58. *
  59. SEGMENT WRK9
  60. REAL*8 YOG(NYOG),YNU(NYNU),YALFA(NYALFA),YSMAX(NYSMAX)
  61. REAL*8 YN(NYN),YM(NYM),YKK(NYKK),YALFA1(NYALF1)
  62. REAL*8 YBETA1(NYBET1),YR(NYR),YA(NYA),YKX(NYKX),YRHO(NYRHO)
  63. REAL*8 SIGY(NSIGY)
  64. INTEGER NKX(NNKX)
  65. ENDSEGMENT
  66. *
  67. SEGMENT WRK91
  68. REAL*8 YOG1(NYOG1),YNU1(NYNU1),YALFT1(NYALFT1),YSMAX1(NYSMAX1)
  69. REAL*8 YN1(NYN1),YM1(NYM1),YKK1(NYKK1),YALF2(NYALF2)
  70. REAL*8 YBET2(NYBET2),YR1(NYR1),YA1(NYA1),YQ1(NYQ1),YRHO1(NYRHO1)
  71. REAL*8 SIGY1(NSIGY1)
  72. ENDSEGMENT
  73. *
  74. SEGMENT WR10
  75. INTEGER IABLO1(NTABO1)
  76. REAL*8 TABLO2(NTABO2)
  77. ENDSEGMENT
  78. *
  79. SEGMENT WR11
  80. INTEGER IABLO3(NTABO3)
  81. REAL*8 TABLO4(NTABO4)
  82. ENDSEGMENT
  83. *
  84. SEGMENT WRK12
  85. real*8 bbet1,bbet2,bbet3,bbet4,bbet5,bbet6,bbet7,bbet8,bbet9
  86. real*8 bbet10,bbet11,bbet12,bbet13,bbet14,bbet15,bbet16,bbet17
  87. real*8 bbet18,bbet19,bbet20,bbet21,bbet22,bbet23,bbet24,bbet25
  88. real*8 bbet26,bbet27,bbet28,bbet29,bbet30,bbet31,bbet32,bbet33
  89. real*8 bbet34,bbet35,bbet36,bbet37,bbet38,bbet39,bbet40,bbet41
  90. real*8 bbet42,bbet43,bbet44,bbet45,bbet46,bbet47,bbet48,bbet49
  91. real*8 bbet50,bbet51,bbet52,bbet53,bbet54,bbet55
  92. integer ibet1,ibet2,ibet3,ibet4,ibet5,ibet6,ibet7,ibet8
  93. integer ibet9,ibet10,ibet11,ibet12,ibet13,ibet14,ibet15,ibet16
  94. ENDSEGMENT
  95.  
  96. C CB215821 : remonté depuis CMAZZZ (MAZARS) pour recyclage puis suppression
  97. SEGMENT WRKK2(0)
  98.  
  99. C CB215821 : remonté depuis CMAXOA & CMAXTA pour recyclage puis suppression
  100. SEGMENT WR12(0)
  101.  
  102. segment wrkgur
  103. real*8 wgur1,wgur2,wgur3,wgur4,wgur5,wgur6,wgur7
  104. real*8 wgur8,wgur9,wgur10,wgur11,wgur12(6)
  105. real*8 wgur13(7), wgur14
  106. real*8 wgur15,wgur16,wgur17
  107. endsegment
  108. C
  109. C Segment de travail pour la loi 'NON_LINEAIRE' 'UTILISATEUR' appelant
  110. C l'integrateur externe specifique UMAT
  111. C
  112. SEGMENT WKUMAT
  113. C Entrees/sorties de la routine UMAT
  114. REAL*8 DDSDDE(NTENS,NTENS), SSE, SPD, SCD,
  115. & RPL, DDSDDT(NTENS), DRPLDE(NTENS), DRPLDT,
  116. & TIME(2), DTIME, TEMP, DTEMP, DPRED(NPRED),
  117. & DROT(3,3), PNEWDT, DFGRD0(3,3), DFGRD1(3,3)
  118. CHARACTER*16 CMNAME
  119. INTEGER NDI, NSHR, NSTATV, NPROPS,
  120. & LAYER, KSPT, KSTEP, KINC
  121. C Variables de travail
  122. LOGICAL LTEMP, LPRED, LVARI, LDFGRD
  123. INTEGER NSIG0, NPARE0, NGRAD0
  124. ENDSEGMENT
  125. C
  126. C Segment de travail pour les lois 'VISCO_EXTERNE'
  127. C
  128. SEGMENT WCREEP
  129. C Entrees/sorties constantes de la routine CREEP
  130. REAL*8 SERD
  131. CHARACTER*16 CMNAMC
  132. INTEGER LEXIMP, NSTTVC, LAYERC, KSPTC
  133. C Entrees/sorties de la routine CREEP pouvant varier
  134. REAL*8 STV(NSTV), STV1(NSTV), STVP1(NSTV),
  135. & STVP2(NSTV), STV12(NSTV), STVP3(NSTV),
  136. & STVP4(NSTV), STV13(NSTV), STVF(NSTV),
  137. & TMP12, TMP, TMP32,
  138. & DTMP12, DTMP,
  139. & PRD12(NPRD), PRD(NPRD), PRD32(NPRD),
  140. & DPRD12(NPRD), DPRD(NPRD)
  141. INTEGER KSTEPC
  142. C Autres indicateurs et variables de travail
  143. LOGICAL LTMP, LPRD, LSTV
  144. INTEGER IVIEX, NPAREC
  145. REAL*8 dTMPdt, dPRDdt(NPRD)
  146. ENDSEGMENT
  147.  
  148. * Segment ECOU: sert de fourre-tout pour les tableaux
  149. *
  150. SEGMENT ECOU
  151. REAL*8 ecow00,ecow0,
  152. 1 ecow1,ecow2,ecow3(6),ecow4(9),ecow5(6),
  153. 2 ecow6(12),ecow7(6),ecow8(6),ecow9(6),ecow10(6),ecow11(6),
  154. 2 ecow12(6),
  155. 1 ecow13(6),ecow14(6),ecow15(12),ecow16(3),
  156. 2 ecow17(6),ecow18(6),ecow19,ecow20
  157. ENDSEGMENT
  158. *
  159. * Segment NECOU utilisé dans ECOINC
  160. *
  161. SEGMENT NECOU
  162. INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  163. . ITYP,IFOURB,IFLUAG,
  164. . ICINE,ITHER,IFLUPL,ICYCL,IBI,
  165. . JFLUAG,KFLUAG,LFLUAG,
  166. . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF
  167. ENDSEGMENT
  168. *
  169. * Segment IECOU: sert de fourre-tout pour les initialisations
  170. * d'entiers
  171. *
  172. SEGMENT IECOU
  173. INTEGER NYOG,NYNU,NYALFA,NYSMAX,NYN,NYM,NYKK,NYALF1,
  174. . NYBET1,NYR,NYA,NYRHO,NSIGY,NNKX,NYKX,IND,NSOM,NINV,
  175. . NINCMA,NCOMP,JELEM,LEGAUS,INAT,NCXMAT,LTRAC,MFRBI,
  176. . IELE,NHRM,NBNNBI,NBELMB,ICARA,LW2BI,NDEF,NSTRSS,
  177. . MFR1,NBGMAT,NELMAT,MSOUPA,NUMAT1,LENDO,NBBB,NNVARI,
  178. . KERR1,MELEMB,NYOG1,NYNU1,NYALFT1,NYSMAX1,NYN1,NYM1,
  179. . NYKK1,NYALF2,NYBET2,NYR1,NYA1,NYQ1,NYRHO1,NSIGY1
  180. ENDSEGMENT
  181. *
  182. * Segment XECOU: sert de fourre-tout pour les initialisations
  183. * de réels
  184. *
  185. SEGMENT XECOU
  186. REAL*8 DTOPTI,TSOM,TCAR,DTT,DT,TREFA,TEMP00
  187. ENDSEGMENT
  188.  
  189. character*16 modemo
  190. LOGICAL dimped, b_moda2
  191. *
  192. * Liste des formulations SIMPLES (cf. MODELI.eso et NOMATE.eso)
  193. *
  194. PARAMETER (MFORMU=17)
  195. CHARACTER*16 LISFOR(MFORMU)
  196. DATA LISFOR /
  197. & 'THERMIQUE ','MECANIQUE ','LIQUIDE ',
  198. & 'CONVECTION ','POREUX ','DARCY ',
  199. & 'FROTTEMENT ','RAYONNEMENT ','MAGNETODYNAMIQUE',
  200. & 'NAVIER_STOKES ','MELANGE ','EULER ',
  201. & 'FISSURE ','LIAISON ','THERMOHYDRIQUE ',
  202. & 'ELECTROSTATIQUE ','DIFFUSION '
  203. & /
  204. *
  205. wrk6 = 0
  206. wrk8 = 0
  207. *** wr10 = 0
  208. wr11 = 0
  209. wr12 = 0
  210. wrk12 = 0
  211. wr13 = 0
  212. WRKK2 = 0
  213. wrkgur =0
  214. wkumat = 0
  215. wcreep = 0
  216. *
  217. c wrk53 reste ouvert en ecriture
  218. SEGINI,wrk53
  219. iwrk53 = wrk53
  220. *
  221. ecou=0
  222. iecou=0
  223. necou=0
  224. xecou=0
  225. SEGINI,ecou,iecou,necou,xecou
  226. * write(ioimp,*) ' coml6 ecou ie ne xe',ecou,iecou,necou,xecou
  227.  
  228. KERRE=0
  229. KERR1=0
  230. c
  231. c moterr(1:6) = 'COML6 '
  232. c moterr(7:15) = 'IMODEL'
  233. c interr(1) = iqmod
  234. c call erreur(-329)
  235. *-------------------------------------------
  236. imodel = iqmod
  237. segact imodel*nomod
  238. *
  239. MELE=NEFMOD
  240. MELEME=IMAMOD
  241. melemb=meleme
  242. ipmail = imamod
  243. CONM = CONMOD
  244. segact meleme*nomod
  245. NBNNbi=NUM(/1)
  246. NBELMb=NUM(/2)
  247. nbnn2=nbnnbi
  248. nbelem2=nbelmb
  249. nbnn=nbnnbi
  250. nbelem=nbelmb
  251. c
  252. c coque integree ou pas ?
  253. c
  254. IF(INFMOD(/1).NE.0)THEN
  255. NPINT=INFMOD(1)
  256. ELSE
  257. NPINT=0
  258. ENDIF
  259. c
  260. NFOR=FORMOD(/2)
  261. NMAT=MATMOD(/2)
  262. c
  263. c Determination de la formulation du modele :
  264. c
  265. lformu = 0
  266. IF (NFOR.EQ.1) THEN
  267. CALL PLACE(LISFOR,MFORMU,lformu,FORMOD(1))
  268. ENDIF
  269. * write(ioimp,*) 'formulation :',lformu,NFOR,FORMOD(1)
  270. if (lformu.eq.0) then
  271. write(ioimp,*) ' Arret dans coml6 : formulation non prevue ici'
  272. call erreur(5)
  273. return
  274. endif
  275. c
  276. c nature du materiau
  277. c
  278. CMATE = CMATEE
  279. MATE = IMATEE
  280. INPLAS = INATUU
  281. c
  282. dimped=.false.
  283. do jmot = 1,nmat
  284. if (matmod(jmot).eq.'IMPEDANCE') dimped = .true.
  285. enddo
  286. b_moda2 = cmate.EQ.'MODAL' .OR. cmate.EQ.'STATIQUE'
  287. if (dimped) then
  288. if (itypel.eq.1) mele = 45
  289. endif
  290. c____________________________________________________________________
  291. c
  292. c information sur l'element fini
  293. c____________________________________________________________________
  294. if(ipinf.ne.0) then
  295. INFO=IPINF
  296. c* segact info
  297. MFRbi =INFELL(13)
  298. NBG =INFELL(6)
  299. NBGS =INFELL(4)
  300. NSTRS=INFELL(16)
  301. LRE =INFELL(9)
  302. LHOOK=INFELL(10)
  303. c* IF (MELE.EQ.96) NBNO = INFELL(8)
  304. IPORE=INFELL(8)
  305. MINTE=INFELL(11)
  306. else
  307. MFRbi =INFELE(13)
  308. NBG =INFELE(6)
  309. NBGS =INFELE(4)
  310. NSTRS=INFELE(16)
  311. LRE =INFELE(9)
  312. LHOOK=INFELE(10)
  313. c* IF (MELE.EQ.96) NBNO = INFELE(8)
  314. IPORE=INFELE(8)
  315. MINTE=INFMOD(2+insupp)
  316. endif
  317. *
  318. MFR=MFRbi
  319. nstrss=nstrs
  320. if (CMATEE.EQ.'IMPELAST'.and.inatuu.ne.161) LHOOK = 6
  321. * On active une fois pour toutes le segment MINTE :
  322. IPMINT = MINTE
  323. IF (IPMINT.GT.0) SEGACT,MINTE
  324. *
  325. IF (MFRbi.EQ.3.AND.NPINT.NE.0) LHOOK=4
  326. LHOO2=LHOOK*LHOOK
  327. *
  328. IF (MFRbi.EQ.33) THEN
  329. NBNO=IPORE
  330. IPPORE=NBNNbi
  331. ELSE
  332. NBNO=NBNNE(NUMGEO(MELE))
  333. IPPORE=0
  334. ENDIF
  335. *
  336. LW =200
  337. LW2bi =150
  338. LW2=150
  339. *-------------------------------------------------
  340. *
  341. NBPTEL=NBGS
  342. NEL=NBELMb
  343. *
  344. N1PTEL=NBPTEL
  345. N1EL=NEL
  346. N2PTEL=0
  347. N2EL=0
  348.  
  349. c pour les variables internes seules
  350. IF (MFRbi.EQ.7.OR.MFRbi.EQ.13) THEN
  351. IF (CMATE.EQ.'SECTION') THEN
  352. C* IF (MATE.EQ.11) THEN <- Test equivalent ?
  353. N2PTEL=NBPTEL
  354. N2EL=NEL
  355. ENDIF
  356. ENDIF
  357. *-------------------------------------------------
  358. * ouverture de tous les melval
  359. * creation wrk52 qui reste ouvert en ecriture
  360. *-------------------------------------------------
  361. CALL COMOUW(iqmod,ipcon,indeso,ipil,iwrk52,iwrk53,iretou,iwr522)
  362.  
  363. *-------------------------------------------------
  364. * complete wrk53
  365. *-------------------------------------------------
  366. wrk52 = iwrk52
  367. c segact wrk52
  368. nmatt = xmat(/1)
  369. NUMAT = nmatt
  370. * ncarr = xcarb(/1)
  371. * NUCAR = ncarr
  372. nvart = var0(/1)
  373. C-------------------------------------------------
  374. C Petits tests de compatibilite des donnees
  375. C pour les lois externes
  376. C-------------------------------------------------
  377. IF (INPLAS.LT.0) THEN
  378. NTURE0 = TURE0(/1)
  379. c IF (NTURE0.NE.0.AND.NTURE0.GT.1) THEN
  380. * write(ioimp,*) 'COML6 : test NTURE0 enleve',NTURE0
  381. c* CALL ERREUR(963)
  382. c* RETURN
  383. c ENDIF
  384. IF (INPLAS.EQ.-1) THEN
  385. NSIGM0 = SIG0(/1)
  386. NEPST0 = EPST0(/1)
  387. IF (NSIGM0.GT.0.AND.NEPST0.GT.0.AND.NSIGM0.NE.NEPST0) THEN
  388. CALL ERREUR(963)
  389. RETURN
  390. ENDIF
  391. ENDIF
  392. ENDIF
  393. *-------------------------------------------------
  394. * creation des deche en sortie
  395. *-------------------------------------------------
  396. CALL COMCRI(iqmod,ipcon,IPMINT,indeso,ipil,insupp,iwrk53,iretou)
  397. if (ierr.ne.0) return
  398. c liluc = ipil
  399.  
  400. * pas de calcul de caracteristiques pour le melange parallele
  401. C* if (formod(1).eq.'MELANGE'.and.cmate.eq.'PARALLEL') goto 1998
  402. if (lformu.eq.11) then
  403. if (cmate.eq.'PARALLEL') goto 1998
  404. endif
  405.  
  406. *-------------------------------------------------
  407. * verification du type des champs
  408. *-------------------------------------------------
  409. CALL COMTRI(iqmod,ipil,wrk53)
  410. if (ierr.ne.0) return
  411. c
  412. *-------------------------------------------------
  413. c Initialisations de variables
  414. *-------------------------------------------------
  415. c - mise à zéro des variables du commun NECOU si besoin
  416. c - modèles viscoplastiques:
  417. c . on récupère le pas de temps
  418. c . on récupère le nombre maximal de sous-pas
  419. c . on met IND=1
  420. c - initialisation des dimensions des tableaux des segments
  421. c Sorties: en plus du commun NECOU, on range les autres données
  422. c initialisées dans les COMMON IECOU et XECOU
  423. CALL COMDEF(iwrk53,necou,iecou,xecou)
  424. IF (KERRE.EQ.999) RETURN
  425. c
  426. * write(ioimp,*) ' coml6 ,cmate,mfrbi,nbno,mele,npint'
  427. * & ,cmate,mfrbi,nbno,mele,npint
  428.  
  429. IPTR1 = 0
  430. IF (MFRbi.EQ. 1 .OR. MFRbi.EQ.31 .OR. MFRbi.EQ.33 .OR.
  431. & MFRbi.EQ.71 .OR. MFRbi.EQ.73) THEN
  432. IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  433. 1 CMATE.EQ.'UNIDIREC') THEN
  434. C* IF (MATE.EQ.2 .OR. MATE.EQ.3 .OR. MATE.EQ.4) THEN <- Test equivalent ?
  435. mele1 = MELE
  436. npint1 = NPINT
  437. nbno1 = NBNO
  438. ielei=iele
  439. CALL RESHPT(1,nbno1,IELEi,mele1,npint1,IPTR1,IRT1)
  440. if (ierr.ne.0) return
  441. MINTE2=IPTR1
  442. SEGACT MINTE2
  443. ENDIF
  444. ENDIF
  445. *
  446. * initialisation des segments de travail
  447. *
  448. SEGINI WRK2,WRK3
  449.  
  450. NBNN = nbnn2
  451. SEGINI,MWRKXE
  452.  
  453. IF (LOGVIS) SEGINI WRK8
  454. IF(INPLAS.EQ.26)THEN
  455. SEGINI WRK6
  456. ENDIF
  457. c
  458. segini wrk54
  459. iwrk54 = wrk54
  460. c ouverture du segment wrk12 ne sert que pour le modele beinsa inplas=66
  461. if(inplas.eq.66) segini wrk12
  462. C ouverture de wrkgur pour modele de gurson inplas=38
  463. if(inplas.eq.38) segini wrkgur
  464.  
  465. C Pour les modeles autres que non lineaires externes :
  466. C pas besoin des coordonnees du point d'integration courant
  467. c Pas besoin de la longueur caracteristique de l'element courant
  468. C On les met a zero une fois pour toutes
  469. COORGA(1)=0.0D0
  470. COORGA(2)=0.0D0
  471. COORGA(3)=0.0D0
  472. LCARAC=0.0D0
  473.  
  474. C Objets de travail pour une loi non lineaire externe
  475. IF (INPLAS.LT.0) THEN
  476. IF (INPLAS.EQ.-1) THEN
  477. NTENS=SIG0(/1)
  478. NPRED=PAREX0(/1)
  479. SEGINI,WKUMAT
  480. IFORB=IFOURB
  481. CALL WKUMA0 ( iqmod, iwrk52, wkumat, IFORB )
  482. C* ELSE IF (INPLAS.EQ.-2) THEN
  483. ELSE
  484. NSTV=VAR0(/1)-4
  485. IF (NSTV.EQ.0) NSTV=1
  486. NPRD=PAREX0(/1)
  487. SEGINI,WCREEP
  488. CALL WCREE0 ( iqmod, iwrk52, wcreep )
  489. ENDIF
  490. C*TMP Deb On met dans wrk53.jecher le pointeur de la fonction externe
  491. C*TMP Voir plus tard pour affiner via segment wkumat/wcreep...
  492. wrk53.jecher = 0
  493. nobmod = ivamod(/1)
  494. if (nobmod.gt.0) then
  495. noblib = 0
  496. CALL PLACE(tymode,nobmod,noblib,'LMEEXT ')
  497. if (noblib.ne.0) then
  498. wrk53.jecher = ivamod(noblib)
  499. endif
  500. endif
  501. C*TMP Fin
  502. ENDIF
  503. *
  504. * write(6,*)'coml6 ,nel,nbptel,inplas,mfrbi,cmate,mate,ifour,mele'
  505. * write(6,*)'coml6 ',nel,nbptel,inplas,mfrbi,cmate,mate,ifour,mele
  506. * boucles
  507. ncourb=0
  508. ** segini wrk7
  509. wrk7=0
  510. NYOG=0
  511. NYNU=0
  512. NYALFA=0
  513. NYSMAX=0
  514. NYN=0
  515. NYM=0
  516. NYKK=0
  517. NYALF1=0
  518. NYBET1=0
  519. NYR=0
  520. NYA=0
  521. NYKX=0
  522. NYRHO=0
  523. NSIGY=0
  524. NNKX=0
  525. ** segini wrk9
  526. wrk9=0
  527. NYOG1=0
  528. NYNU1=0
  529. NYALFT1=0
  530. NYSMAX1=0
  531. NYN1=0
  532. NYM1=0
  533. NYKK1=0
  534. NYALF2=0
  535. NYBET2=0
  536. NYR1=0
  537. NYA1=0
  538. NYQ1=0
  539. NYRHO1=0
  540. NSIGY1=0
  541. ** segini wrk91
  542. wrk91=0
  543.  
  544. do 1000 ib=1,nel
  545.  
  546. * (MWRKXE) Recuperation des coordonnees des noeuds de l'element
  547. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  548.  
  549. * (WRK54) calcul des axes locaux
  550. CALL COMROT(iwrk53,IB,IPTR1,MWRKXE,iwrk54)
  551. if (ierr.ne.0) return
  552.  
  553. * CALCUL DE LA LONGUEUR CARACTERISTIQUE DE L'éLéMENT COURANT
  554. * POUR MODèLE BETON URGC INSA
  555. IF ((INPLAS.GE.99.AND.INPLAS.LE.101).OR.
  556. 1 (INPLAS.GE.120.AND.INPLAS.LE.122)) THEN
  557. CALL LONGCA(IPMAIL,IB,BID(1))
  558. ENDIF
  559.  
  560. * Modeles non lineaires externes 'NON_LINEAIRE' 'UTILISATEUR' :
  561. * - Releve des coordonnees des noeuds de l'element courant,
  562. * - Calcul de la longueur caracteristique de l'element courant
  563. * - Releve de la matrice de passage DROT du repere local de l'element
  564. * fini massif au repere general du maillage
  565. IF (INPLAS.EQ.-1) THEN
  566. IF (IPTR1.NE.0) THEN
  567. DO 200 J=1,IDIM
  568. DO 200 I=1,IDIM
  569. DROT(I,J)=TXR(I,J)
  570. 200 CONTINUE
  571. ENDIF
  572. CALL LOCARA(IDIM,NBNN,XEL,LCARAC)
  573. ENDIF
  574.  
  575. DO 100 igau =1,nbptel
  576.  
  577. * -recuperation de valmat et de valcar
  578. * -on recupere les contraintes initiales
  579. * -on recupere les variables internes
  580. * -on recupere les deformations inelastiques initiales si besoin
  581. * -on recupere les increments de deformations totales
  582. * -on cherche la section de l'element ib
  583. * -prise en compte de l'epaisseur et de l'excentrement
  584. * dans le cas des coques minces avec ou sans cisaillement
  585. * transverse
  586. *
  587. * on recupere les constantes du materiau
  588. * calcul des contraintes effectives en milieu poreux
  589. *
  590. * --- remplissage de wrk52
  591. * on recupere les caracteristiques geometriques
  592. CALL COMVAL(iqmod,indeso,ipil,iwrk52,iwrk53,ib,igau,
  593. & necou,iecou,xecou,iwr522)
  594. if (ierr.ne.0) return
  595. *
  596. *---- quelques arrangements
  597. CALL COMARA(IQMOD,IWRK52,IWRK53,IWRK54,wrk2,wr10,ib,igau,
  598. & iretou,necou,iecou,xecou,itruli)
  599. if (ierr.ne.0) return
  600. if (iretou.ne.0) goto 1990
  601. * >>>>>>>>>> fin du traitement du materiau
  602. *
  603. C Pour les modeles non lineaires externes : calcul des coordonnees
  604. C du point d'integration courant
  605. IF (INPLAS.LT.0) THEN
  606. DO 101 IX=1,IDIM
  607. r_z = 0.0D0
  608. DO 102 INO=1,NBNN
  609. r_z = r_z +XEL(IX,INO)*SHPTOT(1,INO,IGAU)
  610. 102 CONTINUE
  611. COORGA(IX) = r_z
  612. 101 CONTINUE
  613. ENDIF
  614. *
  615. * lois au point d integration
  616. c
  617. c traitement du modele
  618. c
  619. c Branchement suivant la formulation :
  620. c
  621. GOTO (9999,9002,9999,9999,9002,9999,9999,9999,9999,9999,9011,9999,
  622. & 9999,9014,9999,9999,9017),lformu
  623.  
  624. 9999 CONTINUE
  625. c---- FORMULATION : THERMIQUE / LIQUIDE / CONVECTION /
  626. c DARCY / FROTTEMENT / RAYONNEMENT /
  627. c MAGNETODYNAMIQUE / NAVIER_STOKES /
  628. c EULER / FISSURE / THERMOHYDRIQUE /
  629. c ELECTROSTATIQUE / DIFFUSION
  630. * write(ioimp,*) 'Formulation non implementee'
  631. RETURN
  632. c
  633. c---- FORMULATION : MECANIQUE / POREUX
  634. 9002 CONTINUE
  635. IF (b_moda2.or.(dimped.and.inatuu.ge.161.and.inatuu.le.164)) THEN
  636. iforb=ifourb
  637. nbgmab=nbgmat
  638. nlmatb=nelmat
  639. xdt = dt
  640. CALL cmoda2(wrk52,wrk53,xdt,ib,igau,nbpgau,nbgmab,nlmatb,iforb)
  641. ifourb=iforb
  642. nbgmat=nbgmab
  643. nelmat=nlmatb
  644. ELSE
  645. jnppla=inplas+3
  646. * Cas VISCO_EXTERNE (inplas = -2) et UMAT (inplas = -1)
  647. GOTO( 8, 8,
  648. * inplas 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
  649. $ 7,7, 8, 7, 7, 7,111, 7,111, 8,111,111, 7,111, 8, 7,
  650. * 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
  651. $ 8, 7, 8, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8,
  652. * 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
  653. $ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7,
  654. * 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
  655. $ 111, 8, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8, 8, 8,
  656. * 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
  657. $ 7, 8, 7, 8, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8,
  658. * 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
  659. $ 7, 7, 8, 8, 8,111, 7,111, 7, 7, 7, 7, 8, 8, 7,
  660. * 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  661. $ 8, 8, 8, 7, 7, 8, 8, 8, 7, 7, 7, 7, 7, 8, 7,
  662. * 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
  663. $ 8, 7, 8,111,111, 7, 7, 7,111,111,111,111, 8, 8, 7,
  664. * 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
  665. $ 7, 7,111,111, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8,
  666. * 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
  667. $ 7, 7, 7, 7, 8, 8, 8, 8, 12, 12, 12, 8, 111,111, 8,
  668. * 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
  669. $ 8, 8, 12, 12, 8, 8, 12, 12, 12, 12,12, 12, 12, 12, 12,
  670. * 166 167 168 169 170 171 172 173 174 175 176 177
  671. $ 12, 12, 12, 12, 12, 12, 12, 12, 8, 12, 12, 12
  672. $ )jnppla
  673. 111 continue
  674. * write(ioimp,*) ' stop dans coml6 : comportement pas prevu ici'
  675. * write(ioimp,*) ' inplas jnppla ',inplas,jnppla
  676. CALL erreur(5)
  677. return
  678. 7 continue
  679. * if(ib.eq.1.and.igau.eq.1) write(ioimp,*) 'appel coml7'
  680. CALL coml7(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  681. & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,wr11,
  682. & iretou,wrk12,wr13,wrkgur,wkumat,wcreep,ecou,iecou,necou,xecou)
  683. go to 2000
  684. 8 continue
  685. * if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml8'
  686. CALL coml8(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  687. & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,wr11,
  688. & iretou,wrk12,WR12,WRKK2,wrkgur,wkumat,wcreep,ecou,iecou,necou,
  689. & xecou)
  690. go to 2000
  691. 12 continue
  692. C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml12'
  693. CALL coml12(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  694. & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,wr11,
  695. & iretou,wrk12,wrkgur,wkumat,wcreep,ecou,iecou,necou,xecou)
  696. go to 2000
  697. ENDIF
  698. GOTO 2000
  699.  
  700. c---- FORMULATION : MELANGE (microstructures)
  701. 9011 CONTINUE
  702. *
  703. IF (CMATE.EQ.'MGRAIN') THEN
  704. CALL mgrain(xmat0,ture0,xmatf,turef)
  705.  
  706. ELSE if (CMATE.EQ.'CEREM') then
  707. * constituer en cas de besoin les nuages d interpolation
  708. ipnua1 = int(xmat0(16))
  709. modemo = 'CEREMREFR'
  710. CALL copret(ipnua1,ilent1,modemo)
  711. if (ilent1.eq.0) then
  712. CALL chist(ipnua1,ilent1,iwrk52,modemo)
  713. if (ierr.ne.0) return
  714. call compre(ipnua1,ilent1,modemo)
  715. endif
  716. *
  717. modemo = 'CEREMCHAU'
  718. ipnua1 = int(xmat0(17))
  719. call copret(ipnua1,ilent2,modemo)
  720. if (ilent2.eq.0) then
  721. call chist(ipnua1,ilent2,iwrk52,modemo)
  722. if (ierr.ne.0) return
  723. call compre(ipnua1,ilent2,modemo)
  724. endif
  725. *
  726. call CRPHA3(iwrk52,iwrk53,ilent1,ilent2,IB,igau)
  727. *
  728. ELSE if (CMATE.EQ.'LEBLOND') then
  729. call clebl3(iwrk52,IB,igau)
  730. *
  731. ELSE if (CMATE.EQ.'ZTMAX') then
  732. call cztmax(iwrk52,iwrk53, ib,igau)
  733. *
  734. ELSE if (CMATE.EQ.'TMM_LMT2') then
  735. call t4m(iwrk52,iwrk53, ib,igau)
  736. *
  737. ENDIF
  738. GOTO 2000
  739.  
  740. c---- FORMULATION : LIAISON
  741. 9014 CONTINUE
  742. if (itruli.le.0) then
  743. write(ioimp,*) ' stop dans coml6 : itruli <= 0'
  744. call erreur(5)
  745. return
  746. endif
  747. if (mate.ge.23) then
  748. call coml11(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  749. else
  750. call coml10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  751. endif
  752. GOTO 2000
  753.  
  754. c----- FORMULATION : DIFFUSION
  755. 9017 CONTINUE
  756. * write(ioimp,*) 'DIFFUSION : a faire !!!'
  757. CALL coml14(iqmod,iwrk52,iwrk53,ib,igau,iretou)
  758. GOTO 2000
  759.  
  760. * Erreurs
  761. *
  762. 2000 continue
  763. if (ierr.ne.0) return
  764. *
  765. * - problèmes de convergence
  766. *
  767. interr(3) = inplas
  768. CALL DEFER1(JNOID,KERR1,KERRE,LOGSUC)
  769. if (ierr.ne.0) return
  770. *
  771. * - autres problèmes
  772. *
  773. 1990 CONTINUE
  774. IF (kerre.NE.0) THEN
  775. jnplas = inplas
  776. jmfr = mfrbi
  777. jmele = mele
  778. jkerr1 = kerr1
  779. jkerre = kerre
  780. if (jnplas.LT.0) MOTERR(5:20) = wkumat.cmname(1:16)
  781. CALL DEFER2(JNPLAS,JMFR,JMELE,IB,IGAU, jkerr1,jkerre)
  782. if (ierr.ne.0) return
  783. ENDIF
  784. c
  785. c remplissage des melval contenant les contraintes a la fin
  786. * ( rearrangement pour milieu poreux ),
  787. c les variables internes finales
  788. c et les increments de deformations plastiques
  789. c stocke pas de temps optimal
  790. c
  791. CALL COMSOR(iqmod,ipil,iwrk52,iwrk53,iwrk54,ib,igau,iecou,xecou)
  792. if (ierr.ne.0) return
  793. c
  794. C-----------------------------------------------------------------------
  795. c fin de la boucle sur les points de gauss
  796. 100 continue
  797. C-----------------------------------------------------------------------
  798. c
  799. c special poutres et tuyaux sauf timoschenko
  800. c
  801. if (.not.dimped) then
  802. CALL COMPOU(IB,mwrkxe,ipil,iwrk53)
  803. if (ierr.ne.0) return
  804. endif
  805. C-----------------------------------------------------------------------
  806. c fin de la boucle sur les elements
  807. 1000 continue
  808. C-----------------------------------------------------------------------
  809. *
  810. C Desactivation de segments
  811. IF (IPMINT.GT.0) SEGDES,MINTE
  812. IF (IPTR1.NE.0) THEN
  813. C* IF (MFRbi.EQ. 1 .OR. MFRbi.EQ.31 .OR. MFRbi.EQ.33 .OR.
  814. C* & MFRbi.EQ.71 .OR. MFRbi.EQ.73) THEN
  815. C* IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  816. C* 1 CMATE.EQ.'UNIDIREC') THEN
  817. C*C* IF (MATE.EQ.2 .OR. MATE.EQ.3 .OR. MATE.EQ.4) THEN <- Test equivalent ?
  818. SEGDES MINTE2
  819. C* ENDIF
  820. ENDIF
  821. c Destruction des segments de travail
  822. if (wrk7.ne.0) SEGSUP wrk7
  823. if (wrk9.ne.0) SEGSUP wrk9
  824. if (wrk91.ne.0) SEGSUP wrk91
  825. SEGSUP WRK2,WRK3
  826. SEGSUP MWRKXE
  827. *** IF (wrk6.NE.0) SEGSUP,WRK6
  828. IF (LOGVIS) SEGSUP,WRK8
  829. **** if (wr10.ne.0) segsup wr10
  830. if (wr11.ne.0) segsup wr11
  831. if (wrk12.ne.0) segsup wrk12
  832. if (wr12.ne.0) segsup wr12
  833. if (WRKK2.ne.0) segsup WRKK2
  834. if (wrkgur.ne.0) segsup wrkgur
  835. IF (wkumat.ne.0) SEGSUP,WKUMAT
  836. IF (wcreep.ne.0) SEGSUP,WCREEP
  837. segsup wrk54
  838. 1998 CONTINUE
  839. segsup wrk53
  840. segsup ecou,iecou,necou,xecou
  841.  
  842. c Fermeture des melval & destruction des segments associes
  843. CALL COMFIN(ipil,iwrk52,iwr522)
  844.  
  845. return
  846. end
  847.  
  848.  
  849.  
  850.  
  851.  

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