Télécharger coml6.eso

Retour à la liste

Numérotation des lignes :

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

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