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

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