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    SP204843  25/10/30    21:15:04     12389          
  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.       SEGMENT WRK2
  32.         REAL*8 TRAC(LTRAC)
  33.       ENDSEGMENT
  34. *
  35.       SEGMENT MWRKXE
  36.         REAL*8 XEL(3,NBNN)
  37.       ENDSEGMENT
  38. *
  39.       SEGMENT WRK3
  40.         REAL*8 WORK(LW),WORK2(LW2bi)
  41.       ENDSEGMENT
  42. *
  43.       SEGMENT WRK6
  44.         REAL*8 BB(NSTRS,NNVARI),R(NSTRS),XMU(NSTRS)
  45.         REAL*8 S(NNVARI),QSI(NNVARI),DDR(NSTRS),BBS(NSTRS)
  46.         REAL*8 SIGMA(NSTRS),SIGGD(NSTRS),XMULT(NSTRS),PROD(NSTRS)
  47.       ENDSEGMENT
  48. *
  49.       SEGMENT WRK7
  50.         REAL*8 F(NCOURB,2),W(NCOURB),TRUC(NCOURB)
  51.       ENDSEGMENT
  52. *
  53.       SEGMENT WRK8
  54.         REAL*8 DD(NSTRS,NSTRS),DDV(NSTRS,NSTRS),DDINV(NSTRS,NSTRS)
  55.         REAL*8 DDINVp(NSTRS,NSTRS)
  56.       ENDSEGMENT
  57. *
  58.       SEGMENT WRK9
  59.         REAL*8 YOG(NYOG),YNU(NYNU),YALFA(NYALFA),YSMAX(NYSMAX)
  60.         REAL*8 YN(NYN),YM(NYM),YKK(NYKK),YALFA1(NYALF1)
  61.         REAL*8 YBETA1(NYBET1),YR(NYR),YA(NYA),YKX(NYKX),YRHO(NYRHO)
  62.         REAL*8 SIGY(NSIGY)
  63.         INTEGER NKX(NNKX)
  64.       ENDSEGMENT
  65. *
  66.       SEGMENT WRK91
  67.         REAL*8 YOG1(NYOG1),YNU1(NYNU1),YALFT1(NYALFT1),YSMAX1(NYSMAX1)
  68.         REAL*8 YN1(NYN1),YM1(NYM1),YKK1(NYKK1),YALF2(NYALF2)
  69.         REAL*8 YBET2(NYBET2),YR1(NYR1),YA1(NYA1),YQ1(NYQ1),YRHO1(NYRHO1)
  70.         REAL*8 SIGY1(NSIGY1)
  71.       ENDSEGMENT
  72. *
  73.       SEGMENT WR10
  74.         INTEGER IABLO1(NTABO1)
  75.         REAL*8  TABLO2(NTABO2)
  76.       ENDSEGMENT
  77. *
  78. *  AM  sellier 26_03_20   
  79.       SEGMENT WR14
  80.         INTEGER INLVIA(NBVIA)
  81.       ENDSEGMENT  
  82. *
  83.       SEGMENT WRK12
  84.        real*8  bbet1,bbet2,bbet3,bbet4,bbet5,bbet6,bbet7,bbet8,bbet9
  85.        real*8 bbet10,bbet11,bbet12,bbet13,bbet14,bbet15,bbet16,bbet17
  86.        real*8 bbet18,bbet19,bbet20,bbet21,bbet22,bbet23,bbet24,bbet25
  87.        real*8 bbet26,bbet27,bbet28,bbet29,bbet30,bbet31,bbet32,bbet33
  88.        real*8 bbet34,bbet35,bbet36,bbet37,bbet38,bbet39,bbet40,bbet41
  89.        real*8 bbet42,bbet43,bbet44,bbet45,bbet46,bbet47,bbet48,bbet49
  90.        real*8 bbet50,bbet51,bbet52,bbet53,bbet54,bbet55
  91.        integer ibet1,ibet2,ibet3,ibet4,ibet5,ibet6,ibet7,ibet8
  92.        integer ibet9,ibet10,ibet11,ibet12,ibet13,ibet14,ibet15,ibet16
  93.       ENDSEGMENT
  94.  
  95. C     CB215821 : remonté depuis CMAZZZ (MAZARS) pour recyclage puis suppression
  96.       SEGMENT WRKK2(0)
  97.  
  98. C     CB215821 : remonté depuis CMAXOA & CMAXTA pour recyclage puis suppression
  99.       SEGMENT WR12(0)
  100.  
  101.       segment wrkgur
  102.         real*8 wgur1,wgur2,wgur3,wgur4,wgur5,wgur6,wgur7
  103.         real*8  wgur8,wgur9,wgur10,wgur11,wgur12(6)
  104.         real*8 wgur13(7), wgur14
  105.         real*8 wgur15,wgur16,wgur17
  106.       endsegment
  107. C
  108. C Segment de travail pour la loi 'NON_LINEAIRE' 'UTILISATEUR' appelant
  109. C l'integrateur externe specifique UMAT
  110. C
  111.       SEGMENT WKUMAT
  112. C        Entrees/sorties de la routine UMAT
  113.          REAL*8        DDSDDE(NTENS,NTENS), SSE, SPD, SCD,
  114.      &                 RPL, DDSDDT(NTENS), DRPLDE(NTENS), DRPLDT,
  115.      &                 TIME(2), DTIME, TEMP, DTEMP, DPRED(NPRED),
  116.      &                 DROT(3,3), PNEWDT, DFGRD0(3,3), DFGRD1(3,3)
  117.          CHARACTER*16  CMNAME
  118.          INTEGER       NDI, NSHR, NSTATV, NPROPS,
  119.      &                 LAYER, KSPT, KSTEP, KINC
  120. C        Variables de travail
  121.          LOGICAL       LTEMP, LPRED, LVARI, LDFGRD
  122.          INTEGER       NSIG0, NPARE0, NGRAD0
  123.       ENDSEGMENT
  124. C
  125. C Segment de travail pour les lois 'VISCO_EXTERNE'
  126. C
  127.       SEGMENT WCREEP
  128. C        Entrees/sorties constantes de la routine CREEP
  129.          REAL*8        SERD
  130.          CHARACTER*16  CMNAMC
  131.          INTEGER       LEXIMP, NSTTVC, LAYERC, KSPTC
  132. C        Entrees/sorties de la routine CREEP pouvant varier
  133.          REAL*8        STV(NSTV),    STV1(NSTV),  STVP1(NSTV),
  134.      &                 STVP2(NSTV),  STV12(NSTV), STVP3(NSTV),
  135.      &                 STVP4(NSTV),  STV13(NSTV), STVF(NSTV),
  136.      &                 TMP12,        TMP,         TMP32,
  137.      &                 DTMP12,       DTMP,
  138.      &                 PRD12(NPRD),  PRD(NPRD),   PRD32(NPRD),
  139.      &                 DPRD12(NPRD), DPRD(NPRD)
  140.          INTEGER       KSTEPC
  141. C        Autres indicateurs et variables de travail
  142.          LOGICAL       LTMP, LPRD, LSTV
  143.          INTEGER       IVIEX, NPAREC
  144.          REAL*8        dTMPdt, dPRDdt(NPRD)
  145.       ENDSEGMENT
  146.  
  147. *  Segment ECOU: sert de fourre-tout pour les tableaux
  148. *
  149.       SEGMENT ECOU
  150.        REAL*8 ecow00,ecow0,
  151.      1 ecow1,ecow2,ecow3(6),ecow4(9),ecow5(6),
  152.      2 ecow6(12),ecow7(6),ecow8(6),ecow9(6),ecow10(6),ecow11(6),
  153.      2 ecow12(6),
  154.      1 ecow13(6),ecow14(6),ecow15(12),ecow16(3),
  155.      2 ecow17(6),ecow18(6),ecow19,ecow20
  156.       ENDSEGMENT
  157. *
  158. *  Segment NECOU utilisé dans ECOINC
  159. *
  160.       SEGMENT NECOU
  161.        INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  162.      . ITYP,IFOURB,IFLUAG,
  163.      . ICINE,ITHER,IFLUPL,ICYCL,IBI,
  164.      . JFLUAG,KFLUAG,LFLUAG,
  165.      . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF
  166.       ENDSEGMENT
  167. *
  168. *  Segment IECOU: sert de fourre-tout pour les initialisations
  169. *  d'entiers
  170. *
  171.       SEGMENT IECOU
  172.         INTEGER NYOG,NYNU,NYALFA,NYSMAX,NYN,NYM,NYKK,NYALF1,
  173.      .  NYBET1,NYR,NYA,NYRHO,NSIGY,NNKX,NYKX,IND,NSOM,NINV,
  174.      .  NINCMA,NCOMP,JELEM,LEGAUS,INAT,NCXMAT,LTRAC,MFRBI,
  175.      .  IELE,NHRM,NBNNBI,NBELMB,ICARA,LW2BI,NDEF,NSTRSS,
  176.      .  MFR1,NBGMAT,NELMAT,MSOUPA,NUMAT1,LENDO,NBBB,NNVARI,
  177.      .  KERR1,MELEMB,NYOG1,NYNU1,NYALFT1,NYSMAX1,NYN1,NYM1,
  178.      .  NYKK1,NYALF2,NYBET2,NYR1,NYA1,NYQ1,NYRHO1,NSIGY1
  179.       ENDSEGMENT
  180. *
  181. *  Segment XECOU: sert de fourre-tout pour les initialisations
  182. *  de réels
  183. *
  184.       SEGMENT XECOU
  185.         REAL*8 DTOPTI,TSOM,TCAR,DTT,DT,TREFA,TEMP00
  186.       ENDSEGMENT
  187. C
  188.       character*16 modemo
  189.       character*(LOCHAI)  MOTa
  190.       CHARACTER*4 LEMOT 
  191.       LOGICAL dimped, b_moda2,b_z
  192.       integer wr13
  193.       REAL*8 DDT
  194. C
  195. C======================================================================
  196.       wrk6   = 0
  197.       wrk7   = 0
  198.       wrk8   = 0
  199.       wrk9   = 0
  200.       wr10   = 0
  201.       wr12   = 0
  202.       wrk12  = 0
  203.       wr13   = 0
  204.       wr14   = 0
  205.       WRKK2  = 0
  206.       wrkgur = 0
  207.       wkumat = 0
  208.       wcreep = 0
  209.       WRKMET = 0
  210.       wrk91  = 0
  211.       ecou   = 0
  212.       iecou  = 0
  213.       necou  = 0
  214.       xecou  = 0
  215.       wrk53  = 0
  216. *
  217.       CALL oooprl(1)
  218.       SEGINI,ecou,iecou,necou,xecou,wrk53
  219.       CALL oooprl(0)
  220. C     write(ioimp,*) ' coml6 ecou ie ne xe',ecou,iecou,necou,xecou,wrk53
  221. C
  222. c     moterr(1:6) = 'COML6  '
  223. c     moterr(7:15) = 'IMODEL'
  224. c     interr(1) = iqmod
  225. c     call erreur(-329)
  226. C
  227.       iwrk53 = wrk53
  228.       imodel = iqmod
  229.       MELEME = IMAMOD
  230. C
  231. C     -----------------------------------------------------------------
  232. C     Definir /initialiser les segments wrk53, iecou, necou et xecou
  233. C     -----------------------------------------------------------------
  234.       CALL COMDEF(iwrk53,necou,iecou,xecou,iqmod,insupp,ipmint)
  235.       IF (KERRE.EQ.999) RETURN
  236.       MINTE = IPMINT
  237. C
  238. **    write(6,*) 'coml6 240 nucar ',nucar
  239.       dimped=.false.
  240.       do jmot = 1,nmat
  241.         if (matmod(jmot)(1:10).eq.'IMPEDANCE ') dimped = .true.
  242.       enddo
  243.       b_moda2 = cmate.EQ.'MODAL   ' .OR. cmate.EQ.'STATIQUE'
  244.       if (dimped) then
  245.         if (itypel.eq.1) mele = 45
  246.       endif
  247. * 
  248. *  AM  26_03_20  sellier 
  249. *      recuperation des numeros des variables internes moyennees
  250. *
  251.       IF(INFMOD(/1).GE.13)THEN
  252.          LULVIA=INFMOD(14)
  253.          IF(LULVIA.NE.0) THEN 
  254.             JIL=0
  255.             MLMOT1=LULVIA
  256.             SEGACT, MLMOT1
  257.             NBVIA=MLMOT1.MOTS(/2)
  258.             SEGINI WR14
  259.             NOMID=LNOMID(10)
  260.             IF(NOMID.NE.0) THEN
  261.               SEGACT NOMID      
  262.               DO 251 IU=1,NBVIA  
  263.                 LEMOT=MLMOT1.MOTS(IU)
  264. *               
  265.                 IF(LESOBL(/2).NE.0) THEN              
  266.                   DO 252 JU=1,LESOBL(/2)
  267.                     IF (LEMOT.EQ.LESOBL(JU)) THEN
  268.                       INLVIA(IU)=JU
  269.                       JIL=JIL+1
  270.                       GOTO 251
  271.                     ENDIF
  272. 252               CONTINUE
  273.                 ENDIF
  274. *
  275.                 IF(LESFAC(/2).NE.0) THEN              
  276.                   DO 253 JU=1,LESFAC(/2)
  277.                     IF (LEMOT.EQ.LESFAC(JU)) THEN
  278.                       INLVIA(IU)=JU
  279.                       JIL=JIL+1
  280.                       GOTO 251
  281.                     ENDIF
  282. 253               CONTINUE
  283.                 ENDIF                 
  284. *
  285. 251           CONTINUE 
  286.             ENDIF 
  287.  
  288. c               WRITE(IOIMP,77660)  (INLVIA(IU),IU=1,NBVIA)
  289. 77660          FORMAT(2X,' NUMERO DES VARIABLES INTERNES'/2X,10I5//)
  290.  
  291.             IF(JIL.NE.NBVIA) THEN
  292.                WRITE(IOIMP,77661)  NBVIA,JIL
  293. 77661          FORMAT(2X,'PROBLEME VARIABLES MOYENNEES  NBVIA=',I4,2X,
  294.      &                   'JIL=',I4//)
  295.                CALL ERREUR(31)      
  296.             ENDIF
  297.          ENDIF
  298. *
  299.       ENDIF
  300. ** fin AM sellier 
  301. C
  302. C     FORMULATION METALLURGIE :
  303. C     remplissage des noms des phases, reactifs, produits et types
  304.       if (inatuu .eq. 178) then
  305.         if( ivamod(/1) .lt. 4 ) then
  306.           CALL ERREUR(21)
  307.           RETURN
  308.         endif
  309.         MLMOT1 = ivamod(1)
  310.         MLMOT2 = ivamod(2)
  311.         MLMOT3 = ivamod(3)
  312.         MLMOT4 = ivamod(4)
  313.         NBPHAS = MLMOT1.MOTS(/2)
  314.         NBREAC = MLMOT2.MOTS(/2)
  315.         segini WRKMET
  316.         do i = 1, NBPHAS
  317.           PHASES(i) = MLMOT1.MOTS(i)
  318.         enddo
  319.         do i = 1, NBREAC
  320.           REACTI(i) = MLMOT2.MOTS(i)
  321.           PRODUI(i) = MLMOT3.MOTS(i)
  322.           TYPES(i)  = MLMOT4.MOTS(i)
  323.         enddo
  324.       endif
  325. C
  326. C     -----------------------------------------------------------------
  327. C     Creer/renseigner les segments LILUC et PILNEC qui contiennent
  328. C       LILUC(1,i) = INOMID : pointeur sur un segment nomid
  329. C                             (noms des composantes obl. et fac.)
  330. C       LILUC(2,i) = PILNEC : pointeur sur un segment pilnec
  331. C                             (deche des composantes obl. et fac.)
  332. C     -----------------------------------------------------------------
  333.       CALL COMOUW(iqmod,ipcon,indeso,ipil,iwrk52,iwrk53,iretou,iwr522)
  334.       if (ierr.ne.0) return
  335. **    write(6,*) 'coml6 339 nucar ',nucar 
  336.       wrk52 = iwrk52
  337. CCCCCCC
  338. C     Completer segment IECOU (ajout de valeurs obtenues dans comouw)
  339. **    write(6,*) 'nucar',nucar
  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. 'LOIEXT  ')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. **      write(6,*) 'coml6 jnppla ',jnppla
  568.         GOTO(     8,  8,
  569. * inplas    0 1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  570.      $      7,7,  8,  7,  7,  7,111,  7,111,  8,111,111,  7,111,  8,  7,
  571. *            16  17  18  19  20  21  22  23  24  25  26  27  28  29  30
  572.      $        8,  7,111,  7,  7,  7,  7,  7,  7,  7,  8,  8,  8,  8,  8,
  573. *            31  32  33  34  35  36  37  38  39  40  41  42  43  44  45
  574.      $        8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  7,  7,  7,
  575. *            46  47  48  49  50  51  52  53  54  55  56  57  58  59  60
  576.      $      111,  8,  8,  8,  7,  7,  8,  7,  8,  8,  8,  8,  8,  8,  8,
  577. *            61  62  63  64  65  66  67  68  69  70  71  72  73  74  75
  578.      $        7,  8,  7,  8,  8,  8,  8,  8,  8,  7,  8,  8,  8,  8,  8,
  579. *            76  77  78  79  80  81  82  83  84  85  86  87  88  89  90
  580.      $        7,  7,  8,  8,  8,111,  7,111,  7,  7,  7,  7,  8,  8,  7,
  581. *            91  92  93  94  95  96  97  98  99 100 101 102 103 104 105
  582.      $        8,  8,  8,  7,  7,  8,  8,  8,  7,  7,  7,  7,  7,  8,  7,
  583. *           106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
  584.      $        8,  7,  8,111,111,  7,  7,  7,111,111,111,111,  8,  8,  7,
  585. *           121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
  586.      $        7,  7,111,111,  8,  8,  8,  8,  8,  7,  8,  8,  8,  8,  8,
  587. *           136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
  588.      $        7,  7,  7,  7,  8,  8,  8,  8, 12, 12, 12, 8,   8,111,  8,
  589. *           151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
  590.      $        8,  8, 12, 12,  8,  8, 12, 12, 12, 12,12, 12, 12, 12,   7,
  591. *           166 167 168 169 170  171  172  173 174 175 176 177  178  179
  592.      $        12, 12, 12, 12, 12, 12, 12,  12,   8, 12, 12, 12, 12 , 12, 
  593. c                                       <---Sellier------->   
  594. *           180 181 182 183 184 185 186 187 188 189 190 191 192
  595.      $      12, 12, 12, 12, 12, 12, 12,  7,  7,  7,  7,  7,  7
  596.      $    )jnppla
  597.   111  continue
  598. *       write(ioimp,*) ' stop dans coml6 : comportement pas prevu ici'
  599. *       write(ioimp,*) ' inplas jnppla ',inplas,jnppla
  600.        CALL erreur(5)
  601.        return
  602.     7   continue
  603. **       if(ib.eq.1.and.igau.eq.1) write(ioimp,*) 'appel coml7'
  604.        CALL coml7(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  605.      & wrk2,mwrkxe,wrk3,wrk7,wrk8,wrk9,wrk91,iretou,
  606.      & wr13,wr14,ecou,iecou,necou,xecou,ifus)
  607. **     write(6,*) 'apres coml7 kerre ',kerre
  608.        go to 2000
  609.     8   continue
  610. C       if(ib.eq.1.and.igau.eq.1)  write(ioimp,*) ' appel coml8'
  611.         CALL coml8(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  612.      & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10,
  613.      & iretou,wrk12,WR12,WRKK2,wrkgur,wkumat,wcreep,ecou,iecou,necou,
  614.      &  xecou)
  615.        go to 2000
  616.    12  continue
  617. C        if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml12'
  618.        DDT = dt
  619.        CALL coml12(iqmod,iwrk52,iwrk53,iwrk54,ib,igau,
  620.      & wrk2,mwrkxe,iretou,iecou,necou,DDT)
  621.        go to 2000
  622.       ENDIF
  623.       GOTO 2000
  624. C
  625. C     =================================================================
  626. C     FORMULATION : MELANGE (microstructures)
  627. C     =================================================================
  628.  9011 CONTINUE
  629.       IF (CMATE.EQ.'MGRAIN  ') THEN
  630.         CALL mgrain(xmat0,ture0,xmatf,turef)
  631. *
  632.       ELSE if (CMATE.EQ.'CEREM   ') then
  633. * constituer en cas de besoin les nuages d interpolation
  634.         ipnua1 = int(xmat0(16))
  635. *
  636.         modemo = 'CEREMREFR'
  637.         CALL copret(ipnua1,ilent1,modemo)
  638.         if (ilent1.eq.0)  then
  639.           CALL chist(ipnua1,ilent1,iwrk52,modemo)
  640.           if (ierr.ne.0) return
  641.           call compre(ipnua1,ilent1,modemo)
  642.         endif
  643. C
  644.         modemo = 'CEREMCHAU'
  645.         ipnua1 = int(xmat0(17))
  646.         call copret(ipnua1,ilent2,modemo)
  647.         if (ilent2.eq.0)  then
  648.           call chist(ipnua1,ilent2,iwrk52,modemo)
  649.           if (ierr.ne.0) return
  650.           call compre(ipnua1,ilent2,modemo)
  651.         endif
  652. C
  653.         call CRPHA3(iwrk52,iwrk53,ilent1,ilent2,IB,igau)
  654. C
  655.       ELSE if (CMATE.EQ.'LEBLOND ') then
  656.         call clebl3(iwrk52,IB,igau)
  657. C
  658.       ELSE if (CMATE.EQ.'ZTMAX   ') then
  659.         call cztmax(iwrk52,iwrk53, ib,igau)
  660. C
  661.       ELSE if (CMATE.EQ.'TMM_LMT2') then
  662.         call t4m(iwrk52,iwrk53, ib,igau)
  663. C
  664.       ENDIF
  665.       GOTO 2000
  666. C
  667. C     =================================================================
  668. C     FORMULATION : LIAISON
  669. C     =================================================================
  670.  9014 CONTINUE
  671.       if (itruli.le.0) then
  672. c        write(ioimp,*) ' stop dans coml6 : itruli <= 0'
  673.         call erreur(5)
  674.         return
  675.       endif
  676.       if (mate.ge.23) then
  677.         call coml11(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  678.       else
  679.         call coml10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  680.       endif
  681.       GOTO 2000
  682. C
  683. C     =================================================================
  684. C     FORMULATION : DIFFUSION
  685. C     =================================================================
  686.  9017 CONTINUE
  687. *     write(ioimp,*) 'DIFFUSION : a faire !!!'
  688.       CALL coml14(iqmod,iwrk52,iwrk53,ib,igau,iretou)
  689.       GOTO 2000
  690. C
  691. C     =================================================================
  692. C     FORMULATION : METALLURGIE
  693. C     =================================================================
  694.  9018 CONTINUE
  695. C     Modele metallurgie cree par T.L. en mai 2018
  696.       CALL METALL(iwrk52, WRKMET)
  697.       GOTO 2000
  698. C
  699. C     =================================================================
  700. *
  701. *       Gestion des erreurs
  702. *
  703.  2000   CONTINUE
  704.         if (ierr.ne.0) return
  705. *
  706. *      - problèmes de convergence
  707. *
  708.         interr(3) = inplas
  709.         CALL DEFER1(JNOID,KERR1,KERRE,LOGSUC)
  710.         if (ierr.ne.0) return
  711. *
  712. *      - autres problèmes
  713. *
  714.  1990   CONTINUE
  715.         IF (kerre.NE.0) THEN
  716.           jnplas = inplas
  717.           jmfr = mfrbi
  718.           jmele = mele
  719.           jkerr1 = kerr1
  720.           jkerre = kerre
  721.           if (jnplas.LT.0) MOTERR(5:20) = wkumat.cmname(1:16)
  722.           CALL DEFER2(JNPLAS,JMFR,JMELE,IB,IGAU, jkerr1,jkerre)
  723.           if (ierr.ne.0) return
  724.         ENDIF
  725. c
  726. c     remplissage des melval contenant les contraintes a la fin
  727. *     ( rearrangement pour milieu poreux ),
  728. c     les variables internes finales
  729. c     et les increments de deformations plastiques
  730. c      stocke pas de temps optimal
  731. c
  732.        CALL COMSOR(iqmod,ipil,iwrk52,iwrk53,iwrk54,ib,igau,iecou,xecou)
  733.        if (ierr.ne.0) return
  734. C
  735.   100   CONTINUE
  736. C       -------------------------------------------------------------------
  737. C       Fin de la boucle (100) sur les points d'integration de l'element ib
  738. C       -------------------------------------------------------------------
  739. C
  740. c       special poutres et tuyaux  sauf timoschenko
  741.         if (.not.dimped) then
  742.           CALL COMPOU(IB,mwrkxe,ipil,iwrk53)
  743.           if (ierr.ne.0) return
  744.         endif
  745. C
  746.  1000 CONTINUE
  747. C     ----------------------------------------------------------------------
  748. C     Fin de la boucle (1000) sur les elements du maillage support du imodel
  749. C     ----------------------------------------------------------------------
  750. C
  751. C     Destruction des segments de travail
  752.       if (wrk7.ne.0) SEGSUP wrk7
  753.       if (wrk9.ne.0) SEGSUP wrk9
  754.       if (wrk91.ne.0) SEGSUP wrk91
  755.       SEGSUP WRK2,WRK3
  756.       SEGSUP MWRKXE
  757. ***   IF (WRK6.NE.0)   SEGSUP,WRK6
  758.       IF (LOGVIS)      SEGSUP,WRK8
  759. ****  if (wr10.ne.0)   segsup wr10
  760.       IF (WRK12.NE.0)  SEGSUP WRK12
  761.       IF (WR12.NE.0)   SEGSUP WR12
  762.       IF (WRKK2.NE.0)  SEGSUP WRKK2
  763.       IF (WRKGUR.NE.0) SEGSUP WRKGUR
  764.       IF (WKUMAT.NE.0) SEGSUP,WKUMAT
  765.       IF (WCREEP.NE.0) SEGSUP,WCREEP
  766.       IF (WRKMET.NE.0) SEGSUP,WRKMET
  767.       segsup wrk54
  768.  
  769.  3000 CONTINUE
  770. C       ===============================================================
  771. C        NON LOCAL : MELANGE PARALLELE
  772. C       ===============================================================
  773.       IF (lformu.EQ.11.and.cmatee.eq.'PARALLEL') THEN
  774.         lilcon = ipcon
  775. c
  776. c traite
  777.             call coml9(iqmod,ipcon,iwrk53,indeso,IRETOU,insupp)
  778.         if(ierr.ne.0) return
  779.  
  780.       ENDIF
  781. c fin traitement non local MELANGE
  782. C       ===============================================================
  783. C
  784.  1998 CONTINUE
  785.       segsup wrk53
  786.       segsup ecou,iecou,necou,xecou
  787.  
  788. c Fermeture des melval & destruction des segments associes
  789.       CALL COMFIN(ipil,iwrk52,iwr522)
  790.  
  791.       end
  792.  
  793.  
  794.  
  795.  

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