Télécharger coml6.eso

Retour à la liste

Numérotation des lignes :

coml6
  1. C COML6 SOURCE FD218221 24/02/07 21:15:06 11834
  2.  
  3. SUBROUTINE COML6(iqmod,ipmel,ipcon,ipinf,indeso,insupp,itruli,
  4. > lformu, 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 PPARAM
  18. -INC CCOPTIO
  19. -INC CCGEOME
  20. -INC CCHAMP
  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. * AM sellier 26_03_20
  82. SEGMENT WR14
  83. INTEGER INLVIA(NBVIA)
  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. C
  191. character*16 modemo
  192. character*(LOCHAI) MOTa
  193. CHARACTER*4 LEMOT
  194. LOGICAL dimped, b_moda2,b_z
  195. integer wr13
  196. REAL*8 DDT
  197. C
  198. C======================================================================
  199. wrk6 = 0
  200. wrk7 = 0
  201. wrk8 = 0
  202. wrk9 = 0
  203. wr10 = 0
  204. wr12 = 0
  205. wrk12 = 0
  206. wr13 = 0
  207. wr14 = 0
  208. WRKK2 = 0
  209. wrkgur = 0
  210. wkumat = 0
  211. wcreep = 0
  212. WRKMET = 0
  213. wrk91 = 0
  214. ecou = 0
  215. iecou = 0
  216. necou = 0
  217. xecou = 0
  218. wrk53 = 0
  219. *
  220. CALL oooprl(1)
  221. SEGINI,ecou,iecou,necou,xecou,wrk53
  222. CALL oooprl(0)
  223. C write(ioimp,*) ' coml6 ecou ie ne xe',ecou,iecou,necou,xecou,wrk53
  224. C
  225. c moterr(1:6) = 'COML6 '
  226. c moterr(7:15) = 'IMODEL'
  227. c interr(1) = iqmod
  228. c call erreur(-329)
  229. C
  230. iwrk53 = wrk53
  231. imodel = iqmod
  232. MELEME = IMAMOD
  233. C
  234. C -----------------------------------------------------------------
  235. C Definir /initialiser les segments wrk53, iecou, necou et xecou
  236. C -----------------------------------------------------------------
  237. CALL COMDEF(iwrk53,necou,iecou,xecou,ipinf,iqmod,insupp,ipmint)
  238. IF (KERRE.EQ.999) RETURN
  239. MINTE = IPMINT
  240. C
  241. dimped=.false.
  242. do jmot = 1,nmat
  243. if (matmod(jmot)(1:10).eq.'IMPEDANCE ') dimped = .true.
  244. enddo
  245. b_moda2 = cmate.EQ.'MODAL ' .OR. cmate.EQ.'STATIQUE'
  246. if (dimped) then
  247. if (itypel.eq.1) mele = 45
  248. endif
  249. *
  250. * AM 26_03_20 sellier
  251. * recuperation des numeros des variables internes moyennees
  252. *
  253. IF(INFMOD(/1).GE.13)THEN
  254. LULVIA=INFMOD(14)
  255. IF(LULVIA.NE.0) THEN
  256. JIL=0
  257. MLMOT1=LULVIA
  258. SEGACT, MLMOT1
  259. NBVIA=MLMOT1.MOTS(/2)
  260. SEGINI WR14
  261. NOMID=LNOMID(10)
  262. IF(NOMID.NE.0) THEN
  263. SEGACT NOMID
  264. DO 251 IU=1,NBVIA
  265. LEMOT=MLMOT1.MOTS(IU)
  266. *
  267. IF(LESOBL(/2).NE.0) THEN
  268. DO 252 JU=1,LESOBL(/2)
  269. IF (LEMOT.EQ.LESOBL(JU)) THEN
  270. INLVIA(IU)=JU
  271. JIL=JIL+1
  272. GOTO 251
  273. ENDIF
  274. 252 CONTINUE
  275. ENDIF
  276. *
  277. IF(LESFAC(/2).NE.0) THEN
  278. DO 253 JU=1,LESFAC(/2)
  279. IF (LEMOT.EQ.LESFAC(JU)) THEN
  280. INLVIA(IU)=JU
  281. JIL=JIL+1
  282. GOTO 251
  283. ENDIF
  284. 253 CONTINUE
  285. ENDIF
  286. *
  287. 251 CONTINUE
  288. ENDIF
  289.  
  290. c WRITE(IOIMP,77660) (INLVIA(IU),IU=1,NBVIA)
  291. 77660 FORMAT(2X,' NUMERO DES VARIABLES INTERNES'/2X,10I5//)
  292.  
  293. IF(JIL.NE.NBVIA) THEN
  294. WRITE(IOIMP,77661) NBVIA,JIL
  295. 77661 FORMAT(2X,'PROBLEME VARIABLES MOYENNEES NBVIA=',I4,2X,
  296. & 'JIL=',I4//)
  297. CALL ERREUR(31)
  298. ENDIF
  299. ENDIF
  300. *
  301. ENDIF
  302. ** fin AM sellier
  303. C
  304. C FORMULATION METALLURGIE :
  305. C remplissage des noms des phases, reactifs, produits et types
  306. if (inatuu .eq. 178) then
  307. if( ivamod(/1) .lt. 4 ) then
  308. CALL ERREUR(21)
  309. RETURN
  310. endif
  311. MLMOT1 = ivamod(1)
  312. MLMOT2 = ivamod(2)
  313. MLMOT3 = ivamod(3)
  314. MLMOT4 = ivamod(4)
  315. NBPHAS = MLMOT1.MOTS(/2)
  316. NBREAC = MLMOT2.MOTS(/2)
  317. segini WRKMET
  318. do i = 1, NBPHAS
  319. PHASES(i) = MLMOT1.MOTS(i)
  320. enddo
  321. do i = 1, NBREAC
  322. REACTI(i) = MLMOT2.MOTS(i)
  323. PRODUI(i) = MLMOT3.MOTS(i)
  324. TYPES(i) = MLMOT4.MOTS(i)
  325. enddo
  326. endif
  327. C
  328. C -----------------------------------------------------------------
  329. C Creer/renseigner les segments LILUC et PILNEC qui contiennent
  330. C LILUC(1,i) = INOMID : pointeur sur un segment nomid
  331. C (noms des composantes obl. et fac.)
  332. C LILUC(2,i) = PILNEC : pointeur sur un segment pilnec
  333. C (deche des composantes obl. et fac.)
  334. C -----------------------------------------------------------------
  335. CALL COMOUW(iqmod,ipcon,indeso,ipil,iwrk52,iwrk53,iretou,iwr522)
  336. if (ierr.ne.0) return
  337. wrk52 = iwrk52
  338. CCCCCCC
  339. C Completer segment IECOU (ajout de valeurs obtenues dans comouw)
  340. ICARA=NUCAR
  341. NCXMAT=NMATT
  342. NUMAT1=NUMAT
  343. IF(INPLAS.EQ.26)THEN
  344. INAT=INPLAS
  345. NNVARI=2
  346. NUMAT=NUMAT+4
  347. ELSE IF (INPLAS.EQ.29.OR.INPLAS.EQ.142) THEN
  348. INAT=INPLAS
  349. ENDIF
  350. CCCCCCC
  351. C -----------------------------------------------------------------
  352. C Creation des deche en sortie
  353. C -----------------------------------------------------------------
  354. CALL oooprl(1)
  355. CALL COMCRI(iqmod,ipcon,IPMINT,indeso,ipil,insupp,iwrk53,iretou)
  356. CALL oooprl(0)
  357. if (ierr.ne.0) return
  358. C
  359. C pas de calcul de caracteristiques pour le melange parallele
  360. if (lformu.eq.11) then
  361. if (cmate.eq.'PARALLEL') goto 3000
  362. endif
  363. *
  364. IPTR1 = 0
  365. IF (MFRbi.EQ. 1 .OR. MFRbi.EQ.31 .OR. MFRbi.EQ.33 .OR.
  366. & MFRbi.EQ.71 .OR. MFRbi.EQ.73) THEN
  367. IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR.
  368. 1 CMATE.EQ.'UNIDIREC') THEN
  369. mele1 = MELE
  370. npint1 = NPINT
  371. nbno1 = NBNO
  372. ielei=iele
  373. CALL RESHPT(1,nbno1,IELEi,mele1,npint1,IPTR1,IRT1)
  374. if (ierr.ne.0) return
  375. MINTE2=IPTR1
  376. SEGACT MINTE2
  377. ENDIF
  378. ENDIF
  379. C
  380. C -----------------------------------------------------------------
  381. C Initialisation des segments de travail supplementaires .....
  382. C -----------------------------------------------------------------
  383. CALL oooprl(1)
  384. SEGINI WRK2,WRK3
  385.  
  386. NBNN = nbnn2
  387. SEGINI,MWRKXE
  388.  
  389. IF (LOGVIS) SEGINI WRK8
  390. IF (INPLAS.EQ.26) SEGINI WRK6
  391. IF (INPLAS.EQ.66) SEGINI WRK12
  392. IF (INPLAS.EQ.38) SEGINI WRKGUR
  393. C
  394. segini wrk54
  395. iwrk54 = wrk54
  396. C
  397. C Objets de travail pour une loi non lineaire externe
  398. IF (INPLAS.LT.0) THEN
  399. IF (INPLAS.EQ.-1) THEN
  400. NTENS=SIG0(/1)
  401. NPRED=PAREX0(/1)
  402. SEGINI,WKUMAT
  403. IFORB=IFOURB
  404. CALL WKUMA0(iqmod, iwrk52, wkumat, IFORB)
  405. C* ELSE IF (INPLAS.EQ.-2) THEN
  406. ELSE
  407. NSTV=VAR0(/1)-4
  408. IF (NSTV.EQ.0) NSTV=1
  409. NPRD=PAREX0(/1)
  410. SEGINI,WCREEP
  411. CALL WCREE0(iqmod, iwrk52, wcreep)
  412. ENDIF
  413. C*TMP Deb On met dans wrk53.jecher le pointeur de la fonction externe
  414. C*TMP Voir plus tard pour affiner via segment wkumat/wcreep...
  415. wrk53.jecher = 0
  416. nobmod = ivamod(/1)
  417. DO 10 II=1,nobmod
  418. IF(TYMODE(II) .EQ. 'MOT ')THEN
  419. IVA=IVAMOD(II)
  420. CALL QUEVAL(IVA,'MOT ',ier,lgmot,r_z,MOTa,b_z,i_z)
  421. IF(ier .NE. 0) CALL ERREUR(5)
  422. IF(MOTa(1:8) .EQ. 'LMEEXT ')THEN
  423. wrk53.jecher = ivamod(II+1)
  424. GOTO 11
  425. ENDIF
  426. ENDIF
  427. 10 CONTINUE
  428. 11 CONTINUE
  429. C*TMP Fin
  430. ENDIF
  431. CALL oooprl(0)
  432. C -----------------------------------------------------------------
  433. *
  434. * write(6,*)'coml6 ,nel,nbptel,inplas,mfrbi,cmate,mate,ifour,mele'
  435. * write(6,*)'coml6 ',nel,nbptel,inplas,mfrbi,cmate,mate,ifour,mele
  436. C
  437. C ------------------------------------------------------------
  438. C Boucle (1000) sur les elements du maillage support du imodel
  439. C ------------------------------------------------------------
  440. DO 1000 IB=1,NBELEM2
  441.  
  442. * (MWRKXE) Recuperation des coordonnees des noeuds de l'element
  443. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  444.  
  445. * (WRK54) Calcul des axes locaux
  446. CALL COMROT(iwrk53,IB,IPTR1,MWRKXE,iwrk54)
  447. if (ierr.ne.0) return
  448.  
  449. * CALCUL DE LA LONGUEUR CARACTERISTIQUE DE L'éLéMENT COURANT
  450. * POUR MODèLE BETON URGC INSA
  451. IF ((INPLAS.GE.99.AND.INPLAS.LE.101).OR.
  452. 1 (INPLAS.GE.120.AND.INPLAS.LE.122)) THEN
  453. CALL LONGCA(IMAMOD,IB,BID(1))
  454. ENDIF
  455.  
  456. * Modeles non lineaires externes 'NON_LINEAIRE' 'UTILISATEUR' :
  457. * - Releve des coordonnees des noeuds de l'element courant,
  458. * - Calcul de la longueur caracteristique de l'element courant
  459. * - Releve de la matrice de passage DROT du repere local de l'element
  460. * fini massif au repere general du maillage
  461. IF (INPLAS.EQ.-1) THEN
  462. IF (IPTR1.NE.0) THEN
  463. DO 200 J=1,IDIM
  464. DO 201 I=1,IDIM
  465. DROT(I,J)=TXR(I,J)
  466. 201 CONTINUE
  467. 200 CONTINUE
  468. ENDIF
  469. CALL LOCARA(IDIM,NBNN,XEL,LCARAC)
  470. ENDIF
  471. C
  472. C ---------------------------------------------------------
  473. C Boucle (100) sur les points d'integration de l'element ib
  474. C ---------------------------------------------------------
  475. DO 100 IGAU =1,NBGS
  476.  
  477. * -recuperation de valmat et de valcar
  478. * -on recupere les contraintes initiales
  479. * -on recupere les variables internes
  480. * -on recupere les deformations inelastiques initiales si besoin
  481. * -on recupere les increments de deformations totales
  482. * -on cherche la section de l'element ib
  483. * -prise en compte de l'epaisseur et de l'excentrement
  484. * dans le cas des coques minces avec ou sans cisaillement
  485. * transverse
  486. *
  487. * on recupere les constantes du materiau
  488. *
  489. * ------- Remplissage de wrk52 et wrk522
  490. * on recupere les caracteristiques geometriques
  491. CALL COMVAL(iqmod,indeso,ipil,iwrk52,iwrk53,ib,igau,iwr522)
  492. IF (IERR.NE.0) RETURN
  493. *
  494. *-------- Quelques arrangements
  495. * calcul des contraintes effectives en milieu poreux
  496. CALL COMARA(IQMOD,IWRK52,IWRK53,IWRK54,wrk2,wr10,
  497. & iretou,necou,iecou,xecou,itruli)
  498. IF (IERR.NE.0) RETURN
  499. IF (IRETOU.NE.0) GOTO 1990
  500. * >>>>>>>>>> fin du traitement du materiau
  501. *
  502. C Pour les modeles non lineaires externes : calcul des coordonnees
  503. C du point d'integration courant
  504. IF (INPLAS.LT.0) THEN
  505. DO 101 IX=1,IDIM
  506. r_z = 0.0D0
  507. DO 102 INO=1,NBNN
  508. r_z = r_z +XEL(IX,INO)*SHPTOT(1,INO,IGAU)
  509. 102 CONTINUE
  510. COORGA(IX) = r_z
  511. 101 CONTINUE
  512. ENDIF
  513. C
  514. C Branchement suivant la formulation (LISFOR dans coml2)
  515. C
  516. GOTO (9999,9002,9999,9999,9002,9999,9999,9999,9999,9999,9011,9999,
  517. & 9999,9014,9999,9999,9017,9018,9999),lformu
  518. C
  519. C =================================================================
  520. C FORMULATIONS NON PREVUES (EVENTUEL POINT DE BRANCHEMENT)
  521. C =================================================================
  522. 9999 CONTINUE
  523. c FORMULATION : THERMIQUE / LIQUIDE / CONVECTION /
  524. c DARCY / FROTTEMENT / RAYONNEMENT /
  525. c MAGNETODYNAMIQUE / NAVIER_STOKES /
  526. c EULER / FISSURE / THERMOHYDRIQUE /
  527. c ELECTROSTATIQUE
  528. * write(ioimp,*) 'Formulation non implementee'
  529. RETURN
  530. C
  531. C =================================================================
  532. C FORMULATIONS : MECANIQUE / POREUX
  533. C =================================================================
  534. 9002 CONTINUE
  535.  
  536. C Traitement comportement mecanique si fusion du materiau
  537. C Si composante TFUS et T>TFUS => IFUS = 1
  538. IFUS = 0
  539. nmat = COMMAT(/2)
  540. DO jmat=1,nmat
  541. C write(6,*) 'COML6, COMMAT(jmat) =',COMMAT(jmat)
  542. IF (COMMAT(jmat).EQ.'TFUS ') THEN
  543. TFUS1 = XMATF(jmat)
  544. TF1 = TUREF(1)
  545. IF (TF1.GT.TFUS1) IFUS = 1
  546. C IF (TF1.GT.TFUS1) write(6,*) 'COML6 : TFUS < TF1 =',TF1
  547. C IF (TF1.GT.TFUS1) write(6,*) 'COML6 : INPLAS =',INPLAS
  548. ENDIF
  549. ENDDO
  550. C
  551. IF (b_moda2.or.(dimped.and.inatuu.ge.161.and.inatuu.le.164)) THEN
  552. iforb=ifourb
  553. nbgmab=nbgmat
  554. nlmatb=nelmat
  555. xdt = dt
  556. CALL cmoda2(wrk52,wrk53,xdt,ib,igau,nbpgau,nbgmab,nlmatb,iforb)
  557. ifourb=iforb
  558. nbgmat=nbgmab
  559. nelmat=nlmatb
  560. ELSE
  561. if (ifus.eq.1) then
  562. jnppla = 3
  563. else
  564. jnppla = inplas+3
  565. endif
  566. * Cas VISCO_EXTERNE (inplas = -2) et UMAT (inplas = -1)
  567. GOTO( 8, 8,
  568. * inplas 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
  569. $ 7,7, 8, 7, 7, 7,111, 7,111, 8,111,111, 7,111, 8, 7,
  570. * 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
  571. $ 8, 7,111, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8,
  572. * 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
  573. $ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7,
  574. * 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
  575. $ 111, 8, 8, 8, 7, 7, 8, 7, 8, 8, 8, 8, 8, 8, 8,
  576. * 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
  577. $ 7, 8, 7, 8, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8,
  578. * 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
  579. $ 7, 7, 8, 8, 8,111, 7,111, 7, 7, 7, 7, 8, 8, 7,
  580. * 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  581. $ 8, 8, 8, 7, 7, 8, 8, 8, 7, 7, 7, 7, 7, 8, 7,
  582. * 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
  583. $ 8, 7, 8,111,111, 7, 7, 7,111,111,111,111, 8, 8, 7,
  584. * 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
  585. $ 7, 7,111,111, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8,
  586. * 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
  587. $ 7, 7, 7, 7, 8, 8, 8, 8, 12, 12, 12, 8, 8,111, 8,
  588. * 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
  589. $ 8, 8, 12, 12, 8, 8, 12, 12, 12, 12,12, 12, 12, 12, 7,
  590. * 166 167 168 169 170 171 172 173 174 175 176 177 178 179
  591. $ 12, 12, 12, 12, 12, 12, 12, 12, 8, 12, 12, 12, 12 , 12,
  592. c <---Sellier------->
  593. * 180 181 182 183 184 185 186 187 188 189 190 191
  594. $ 12, 12, 12, 12, 12, 12, 12, 7, 7, 7, 7, 7
  595. $ )jnppla
  596. 111 continue
  597. * write(ioimp,*) ' stop dans coml6 : comportement pas prevu ici'
  598. * write(ioimp,*) ' inplas jnppla ',inplas,jnppla
  599. CALL erreur(5)
  600. return
  601. 7 continue
  602. C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) 'appel coml7'
  603. CALL coml7(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  604. & wrk2,mwrkxe,wrk3,wrk7,wrk8,wrk9,wrk91,iretou,
  605. & wr13,wr14,ecou,iecou,necou,xecou,ifus)
  606. go to 2000
  607. 8 continue
  608. C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml8'
  609. CALL coml8(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  610. & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,
  611. & iretou,wrk12,WR12,WRKK2,wrkgur,wkumat,wcreep,ecou,iecou,necou,
  612. & xecou)
  613. go to 2000
  614. 12 continue
  615. C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml12'
  616. DDT = dt
  617. CALL coml12(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  618. & wrk2,mwrkxe,iretou,iecou,necou,DDT)
  619. go to 2000
  620. ENDIF
  621. GOTO 2000
  622. C
  623. C =================================================================
  624. C FORMULATION : MELANGE (microstructures)
  625. C =================================================================
  626. 9011 CONTINUE
  627. IF (CMATE.EQ.'MGRAIN ') THEN
  628. CALL mgrain(xmat0,ture0,xmatf,turef)
  629. *
  630. ELSE if (CMATE.EQ.'CEREM ') then
  631. * constituer en cas de besoin les nuages d interpolation
  632. ipnua1 = int(xmat0(16))
  633. *
  634. modemo = 'CEREMREFR'
  635. CALL copret(ipnua1,ilent1,modemo)
  636. if (ilent1.eq.0) then
  637. CALL chist(ipnua1,ilent1,iwrk52,modemo)
  638. if (ierr.ne.0) return
  639. call compre(ipnua1,ilent1,modemo)
  640. endif
  641. C
  642. modemo = 'CEREMCHAU'
  643. ipnua1 = int(xmat0(17))
  644. call copret(ipnua1,ilent2,modemo)
  645. if (ilent2.eq.0) then
  646. call chist(ipnua1,ilent2,iwrk52,modemo)
  647. if (ierr.ne.0) return
  648. call compre(ipnua1,ilent2,modemo)
  649. endif
  650. C
  651. call CRPHA3(iwrk52,iwrk53,ilent1,ilent2,IB,igau)
  652. C
  653. ELSE if (CMATE.EQ.'LEBLOND ') then
  654. call clebl3(iwrk52,IB,igau)
  655. C
  656. ELSE if (CMATE.EQ.'ZTMAX ') then
  657. call cztmax(iwrk52,iwrk53, ib,igau)
  658. C
  659. ELSE if (CMATE.EQ.'TMM_LMT2') then
  660. call t4m(iwrk52,iwrk53, ib,igau)
  661. C
  662. ENDIF
  663. GOTO 2000
  664. C
  665. C =================================================================
  666. C FORMULATION : LIAISON
  667. C =================================================================
  668. 9014 CONTINUE
  669. if (itruli.le.0) then
  670. c write(ioimp,*) ' stop dans coml6 : itruli <= 0'
  671. call erreur(5)
  672. return
  673. endif
  674. if (mate.ge.23) then
  675. call coml11(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  676. else
  677. call coml10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  678. endif
  679. GOTO 2000
  680. C
  681. C =================================================================
  682. C FORMULATION : DIFFUSION
  683. C =================================================================
  684. 9017 CONTINUE
  685. * write(ioimp,*) 'DIFFUSION : a faire !!!'
  686. CALL coml14(iqmod,iwrk52,iwrk53,ib,igau,iretou)
  687. GOTO 2000
  688. C
  689. C =================================================================
  690. C FORMULATION : METALLURGIE
  691. C =================================================================
  692. 9018 CONTINUE
  693. C Modele metallurgie cree par T.L. en mai 2018
  694. CALL METALL(iwrk52, WRKMET)
  695. GOTO 2000
  696. C
  697. C =================================================================
  698. *
  699. * Gestion des erreurs
  700. *
  701. 2000 CONTINUE
  702. if (ierr.ne.0) return
  703. *
  704. * - problèmes de convergence
  705. *
  706. interr(3) = inplas
  707. CALL DEFER1(JNOID,KERR1,KERRE,LOGSUC)
  708. if (ierr.ne.0) return
  709. *
  710. * - autres problèmes
  711. *
  712. 1990 CONTINUE
  713. IF (kerre.NE.0) THEN
  714. jnplas = inplas
  715. jmfr = mfrbi
  716. jmele = mele
  717. jkerr1 = kerr1
  718. jkerre = kerre
  719. if (jnplas.LT.0) MOTERR(5:20) = wkumat.cmname(1:16)
  720. CALL DEFER2(JNPLAS,JMFR,JMELE,IB,IGAU, jkerr1,jkerre)
  721. if (ierr.ne.0) return
  722. ENDIF
  723. c
  724. c remplissage des melval contenant les contraintes a la fin
  725. * ( rearrangement pour milieu poreux ),
  726. c les variables internes finales
  727. c et les increments de deformations plastiques
  728. c stocke pas de temps optimal
  729. c
  730. CALL COMSOR(iqmod,ipil,iwrk52,iwrk53,iwrk54,ib,igau,iecou,xecou)
  731. if (ierr.ne.0) return
  732. C
  733. 100 CONTINUE
  734. C -------------------------------------------------------------------
  735. C Fin de la boucle (100) sur les points d'integration de l'element ib
  736. C -------------------------------------------------------------------
  737. C
  738. c special poutres et tuyaux sauf timoschenko
  739. if (.not.dimped) then
  740. CALL COMPOU(IB,mwrkxe,ipil,iwrk53)
  741. if (ierr.ne.0) return
  742. endif
  743. C
  744. 1000 CONTINUE
  745. C ----------------------------------------------------------------------
  746. C Fin de la boucle (1000) sur les elements du maillage support du imodel
  747. C ----------------------------------------------------------------------
  748. C
  749. C Destruction des segments de travail
  750. if (wrk7.ne.0) SEGSUP wrk7
  751. if (wrk9.ne.0) SEGSUP wrk9
  752. if (wrk91.ne.0) SEGSUP wrk91
  753. SEGSUP WRK2,WRK3
  754. SEGSUP MWRKXE
  755. *** IF (WRK6.NE.0) SEGSUP,WRK6
  756. IF (LOGVIS) SEGSUP,WRK8
  757. **** if (wr10.ne.0) segsup wr10
  758. IF (WRK12.NE.0) SEGSUP WRK12
  759. IF (WR12.NE.0) SEGSUP WR12
  760. IF (WRKK2.NE.0) SEGSUP WRKK2
  761. IF (WRKGUR.NE.0) SEGSUP WRKGUR
  762. IF (WKUMAT.NE.0) SEGSUP,WKUMAT
  763. IF (WCREEP.NE.0) SEGSUP,WCREEP
  764. IF (WRKMET.NE.0) SEGSUP,WRKMET
  765. segsup wrk54
  766.  
  767. 3000 CONTINUE
  768. C ===============================================================
  769. C NON LOCAL : MELANGE PARALLELE
  770. C ===============================================================
  771. IF (lformu.EQ.11.and.cmatee.eq.'PARALLEL') THEN
  772. lilcon = ipcon
  773. c
  774. c traite
  775. call coml9(iqmod,ipcon,iwrk53,ipinf,indeso,IRETOU,insupp)
  776. if(ierr.ne.0) return
  777.  
  778. ENDIF
  779. c fin traitement non local MELANGE
  780. C ===============================================================
  781. C
  782. 1998 CONTINUE
  783. segsup wrk53
  784. segsup ecou,iecou,necou,xecou
  785.  
  786. c Fermeture des melval & destruction des segments associes
  787. CALL COMFIN(ipil,iwrk52,iwr522)
  788.  
  789. end
  790.  
  791.  
  792.  

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