Télécharger coml6.eso

Retour à la liste

Numérotation des lignes :

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

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