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    MB234859  26/01/19    21:15:09     12454          
  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 193
  558.      $      12, 12, 12, 12, 12, 12, 12,  7,  7,  7,  7,  7,  7,  8,   8,
  559.      $       8,  8
  560.      $    ) jnppla
  561.   111  continue
  562. *       write(ioimp,*) ' stop dans coml6 : comportement pas prevu ici'
  563. *       write(ioimp,*) ' inplas jnppla ',jnplas,jnppla
  564.        CALL erreur(5)
  565.        return
  566.     7   continue
  567. **       if(ib.eq.1.and.igau.eq.1) write(ioimp,*) 'appel coml7'
  568.        CALL coml7(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  569.      & wrk2,mwrkxe,wrk3,wrk7,wrk8,wrk9,wrk91,iretou,
  570.      & wr13,wr14,ecou,iecou,necou,xecou,ifus)
  571. **     write(6,*) 'apres coml7 kerre ',kerre
  572.        go to 2000
  573.     8   continue
  574. C       if(ib.eq.1.and.igau.eq.1)  write(ioimp,*) ' appel coml8'
  575.         CALL coml8(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  576.      & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,
  577.      & iretou,wrk12,WR12,WRKK2,wrkgur,wkumat,wcreep,ecou,iecou,necou,
  578.      &  xecou)
  579.        go to 2000
  580.    12  continue
  581. C        if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml12'
  582.        DDT = dt
  583.        CALL coml12(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  584.      & wrk2,mwrkxe,iretou,iecou,necou,DDT)
  585.        go to 2000
  586.       ENDIF
  587.       GOTO 2000
  588. C
  589. C     =================================================================
  590. C     FORMULATION : MELANGE (microstructures)
  591. C     =================================================================
  592.  9011 CONTINUE
  593.       IF (CMATE.EQ.'MGRAIN  ') THEN
  594.         CALL mgrain(xmat0,ture0,xmatf,turef)
  595. *
  596.       ELSE if (CMATE.EQ.'CEREM   ') then
  597. * constituer en cas de besoin les nuages d interpolation
  598.         ipnua1 = int(xmat0(16))
  599. *
  600.         modemo = 'CEREMREFR'
  601.         CALL copret(ipnua1,ilent1,modemo)
  602.         if (ilent1.eq.0)  then
  603.           CALL chist(ipnua1,ilent1,iwrk52,modemo)
  604.           if (ierr.ne.0) return
  605.           call compre(ipnua1,ilent1,modemo)
  606.         endif
  607. C
  608.         modemo = 'CEREMCHAU'
  609.         ipnua1 = int(xmat0(17))
  610.         call copret(ipnua1,ilent2,modemo)
  611.         if (ilent2.eq.0)  then
  612.           call chist(ipnua1,ilent2,iwrk52,modemo)
  613.           if (ierr.ne.0) return
  614.           call compre(ipnua1,ilent2,modemo)
  615.         endif
  616. C
  617.         call CRPHA3(iwrk52,iwrk53,ilent1,ilent2,IB,igau)
  618. C
  619.       ELSE if (CMATE.EQ.'LEBLOND ') then
  620.         call clebl3(iwrk52,IB,igau)
  621. C
  622.       ELSE if (CMATE.EQ.'ZTMAX   ') then
  623.         call cztmax(iwrk52,iwrk53, ib,igau)
  624. C
  625.       ELSE if (CMATE.EQ.'TMM_LMT2') then
  626.         call t4m(iwrk52,iwrk53, ib,igau)
  627. C
  628.       ENDIF
  629.       GOTO 2000
  630. C
  631. C     =================================================================
  632. C     FORMULATION : LIAISON
  633. C     =================================================================
  634.  9014 CONTINUE
  635.       if (itruli.le.0) then
  636. c        write(ioimp,*) ' stop dans coml6 : itruli <= 0'
  637.         call erreur(5)
  638.         return
  639.       endif
  640.       if (mate.ge.23) then
  641.         call coml11(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  642.       else
  643.         call coml10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  644.       endif
  645.       GOTO 2000
  646. C
  647. C     =================================================================
  648. C     FORMULATION : DIFFUSION
  649. C     =================================================================
  650.  9017 CONTINUE
  651. *     write(ioimp,*) 'DIFFUSION : a faire !!!'
  652.       CALL coml14(iqmod,iwrk52,iwrk53,ib,igau,iretou)
  653.       GOTO 2000
  654. C
  655. C     =================================================================
  656. C     FORMULATION : METALLURGIE
  657. C     =================================================================
  658.  9018 CONTINUE
  659. C     Modele metallurgie cree par T.L. en mai 2018
  660.       CALL METALL(iwrk52, WRKMET)
  661.       GOTO 2000
  662. C
  663. C     =================================================================
  664. *
  665. *       Gestion des erreurs
  666. *
  667.  2000   CONTINUE
  668.         if (ierr.ne.0) return
  669. *
  670. *      - probl�mes de convergence
  671. *
  672.         interr(3) = jnplas
  673.         CALL DEFER1(JNOID,KERR1,KERRE,LOGSUC)
  674.         if (ierr.ne.0) return
  675. *
  676. *      - autres probl�mes
  677. *
  678.  1990   CONTINUE
  679.         IF (kerre.NE.0) THEN
  680.           jmfr = mfrbi
  681.           jmele = mele
  682.           jkerr1 = kerr1
  683.           jkerre = kerre
  684.           if (jnplas.LT.0) MOTERR(5:20) = wkumat.cmname(1:16)
  685.           CALL DEFER2(JNPLAS,JMFR,JMELE,IB,IGAU, jkerr1,jkerre)
  686.           if (ierr.ne.0) return
  687.         ENDIF
  688. c
  689. c     remplissage des melval contenant les contraintes a la fin
  690. *     ( rearrangement pour milieu poreux ),
  691. c     les variables internes finales
  692. c     et les increments de deformations plastiques
  693. c      stocke pas de temps optimal
  694. c
  695.        CALL COMSOR(iqmod,ipil,iwrk52,iwrk53,iwrk54,ib,igau,iecou,xecou)
  696.        if (ierr.ne.0) return
  697. C
  698.   100   CONTINUE
  699. C       -------------------------------------------------------------------
  700. C       Fin de la boucle (100) sur les points d'integration de l'element ib
  701. C       -------------------------------------------------------------------
  702. C
  703. c       special poutres et tuyaux  sauf timoschenko
  704.         if (.not.dimped) then
  705.           CALL COMPOU(IB,mwrkxe,ipil,iwrk53)
  706.           if (ierr.ne.0) return
  707.         endif
  708. C
  709.  1000 CONTINUE
  710. C     ----------------------------------------------------------------------
  711. C     Fin de la boucle (1000) sur les elements du maillage support du imodel
  712. C     ----------------------------------------------------------------------
  713. C
  714. C     Destruction des segments de travail
  715.       if (wrk7.ne.0) SEGSUP wrk7
  716.       if (wrk9.ne.0) SEGSUP wrk9
  717.       if (wrk91.ne.0) SEGSUP wrk91
  718.       SEGSUP WRK2,WRK3
  719.       SEGSUP MWRKXE
  720. ***   IF (WRK6.NE.0)   SEGSUP,WRK6
  721.       IF (LOGVIS)      SEGSUP,WRK8
  722. ****  if (wr10.ne.0)   segsup wr10
  723.       IF (WRK12.NE.0)  SEGSUP WRK12
  724.       IF (WR12.NE.0)   SEGSUP WR12
  725.       IF (WRKK2.NE.0)  SEGSUP WRKK2
  726.       IF (WRKGUR.NE.0) SEGSUP WRKGUR
  727.       IF (WKUMAT.NE.0) SEGSUP,WKUMAT
  728.       IF (WCREEP.NE.0) SEGSUP,WCREEP
  729.       IF (WRKMET.NE.0) SEGSUP,WRKMET
  730.       segsup wrk54
  731.  
  732.  3000 CONTINUE
  733. C       ===============================================================
  734. C        NON LOCAL : MELANGE PARALLELE
  735. C       ===============================================================
  736.       IF (lformu.EQ.11.and.cmatee.eq.'PARALLEL') THEN
  737.         lilcon = ipcon
  738. c
  739. c traite
  740.             call coml9(iqmod,ipcon,iwrk53,indeso,IRETOU,insupp)
  741.         if(ierr.ne.0) return
  742.  
  743.       ENDIF
  744. c fin traitement non local MELANGE
  745. C       ===============================================================
  746. C
  747.  1998 CONTINUE
  748.       segsup wrk53
  749.       segsup ecou,iecou,necou,xecou
  750.  
  751. c Fermeture des melval & destruction des segments associes
  752.       CALL COMFIN(ipil,iwrk52,iwr522)
  753.  
  754. c      return
  755.       end
  756.  
  757.  
  758.  
  759.  

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