Télécharger la plaquette Cast3M


fr en

Télécharger coml6.eso

Retour à la liste

Numérotation des lignes : 

coml6

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

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