Télécharger la plaquette Cast3M


fr en

Télécharger config.eso

Retour à la liste

Numérotation des lignes : 

config

  1. C CONFIG    SOURCE    PV090527  25/01/16    21:15:03     12111          
  2.       SUBROUTINE CONFIG     
  3. C=======================================================================
  4. C   OPERATEUR TRANSFORMANT LES CONTRAINTES SUR LA CONFIGURATION COURANTE
  5. C
  6. C       MOD1= OBJET MODELE (TYPE MMODEL)
  7. C
  8. C       SI1 = CHAMP  DE CONTRAINTES (TYPE MCHAML)EN ENTREE
  9. C                OU DE DEFORMATIONS
  10. C
  11. C       SI2 = CHAMP  DE CONTRAINTES (TYPE MCHAML) EN SORTIE
  12. C                OU DE DEFORMATIONS
  13. C
  14. C       CNF = CONFIGURATION COURANTE                                         
  15. C
  16. C       CODE COMBESCURE SEPT 87
  17. C
  18. C=======================================================================
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21.  
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC SMMODEL
  26. -INC SMCHAML
  27. -INC SMCOORD
  28. -INC SMCHPOI 
  29. -INC SMELEME 
  30.       POINTEUR MCHEX1.MCHELM
  31. C
  32.       PARAMETER(NDERI=7)
  33.       CHARACTER*4 MODERI(NDERI)
  34.       DATA MODERI/'LINE','QUAD','I  ','II  ','TRUE','JAUM','UTIL'/
  35. c       -> IDERI =  1      2     1      2      3      4      5
  36. c          traitement particulier uniquement si IDERI = 4 ou 5
  37.  
  38.  
  39.       LOGICAL CARACT
  40.  
  41.       CHARACTER*(LOCOMP) NODEF(3),NODEG(3)
  42.       CHARACTER*(LOCOMP) RODEF(3),RODEG(3)
  43.  
  44.       DATA NODEF / 'UX  ','UY  ','UZ  ' /
  45.       DATA NODEG / 'UR  ','UZ  ','UT  ' /
  46.       DATA RODEF / 'RX  ','RY  ','RZ  ' /
  47.       DATA RODEG / 'RR  ','RZ  ','RT  ' /
  48. C-----------------------------------------------------------------------
  49.  
  50.       IPMODL=0
  51.       IPCHE1=0
  52.       IPCHE2=0
  53.       IPCHP1=0
  54. *as xfem 2010_01_13
  55.       IPCHP0=0
  56.       ICHAX1=0
  57.       IDERI=0
  58.       im=1
  59.       ideri=1
  60.  
  61.       CALL LIROBJ('MMODEL  ',IPMODL,1,IRT1)
  62.       IF(IERR.NE.0) RETURN
  63.       CALL ACTOBJ('MMODEL  ',IPMODL,2)
  64.       IF(IERR.NE.0)RETURN
  65. C
  66. C     ON LIT LE MCHAML A TRANSFORMER
  67. C
  68.       CALL LIROBJ('MCHAML  ',IPIN,1,IRT1)
  69.       if (ipin.eq.0) ierr=2
  70.       IF(IERR.NE.0) RETURN
  71. **    call verrou(2)
  72.       segact mcoord             
  73.       mchelm=ipin
  74. *  sauver les configuration et passage dans mclcnf pour le reduaf
  75.       segact mchelm
  76.       if(mclcnf.eq.0.or.mclcnf.eq.mcoord) then
  77.          call ecrobj('MCHAML  ',ipin)
  78. **       call verrou(3)
  79.          return
  80.       endif
  81.       CALL ACTOBJ('MCHAML  ',IPIN,2)
  82.       mcoor1=mclcnf
  83.       IF(IERR.NE.0) RETURN
  84.       segact mcoord
  85. **    write (6,*) 'mclcnf mcoord avant reduag',mclcnf,mcoord
  86. *  ici faire quelque chose pour que reduaf ne plante pas sur une erreur de configuration
  87.       CALL REDUAG(IPIN,IPMODL,IPCHE1,0,IR,KER)
  88.       if (ierr.ne.0) return
  89.       mchelm=ipche1
  90. **    write (6,*) 'mcoor1 mcoord apres reduag',mcoor1,mcoord
  91.       IF(IR   .NE. 1) CALL ERREUR(KER)
  92.       IF(IERR .NE. 0) RETURN
  93. C
  94. C     ON construit le chpoint de deplacement a partir de la config courante et de celle du
  95. C     chamelem
  96. C
  97.       caract=.false.
  98.        if (titche.eq.'CARACTERISTIQUES') caract=.true.
  99.  
  100.        call lirobj('CHPOINT ',ipchp1,0,iretou)
  101.        mchpoi=ipchp1
  102.       if (iretou.eq.0) then
  103.        segact,mcoord,mcoor1
  104.        nbpts1=mcoor1.xcoor(/1)/(idim+1)
  105.        NAT=2
  106.        NSOUPO=1
  107.        SEGINI MCHPOI
  108.        ipchp1=mchpoi
  109.        NCB=2
  110.        if (ifour.eq.2.or.idim.eq.3) ncB=3
  111.        if (ifour.eq.1) ncB=3
  112.        nc=ncb
  113.        mrotat=mrota
  114.        mrota1=mcoor1.mrota
  115.        if (mrotat.ne.0) then
  116.          nc=2*ncB
  117.          segact mrotat,mrota1
  118.        endif
  119.        SEGINI MSOUPO
  120.        IPCHP(1)=msoupo
  121.        if (ifour.ne.0.and.ifour.ne.1) then
  122.          do i=1,ncb
  123.            nocomp(i)=nodef(i)
  124.          enddo
  125.        else
  126.          do i=1,ncb
  127.            nocomp(i)=nodeg(i)
  128.          enddo
  129.        endif
  130.        if (mrotat.ne.0) then
  131.        if (ifour.ne.0.and.ifour.ne.1) then
  132.          do i=1,ncb
  133.            nocomp(i+ncb)=rodef(i)
  134.          enddo
  135.        else
  136.          do i=1,ncb
  137.            nocomp(i+ncb)=rodeg(i)
  138.          enddo
  139.        endif
  140.        endif
  141.        N=nbpts
  142.        segini mpoval
  143.        ipoval=mpoval
  144. **     write(6,*) 'config icar',icar
  145.        if(     caract) then
  146. **     write(6,*) 'config mcoord mcoor1',mcoord,mcoor1
  147.        do i=1,min(nbpts,nbpts1)
  148.        do j=1,idim
  149.         ij=(i-1)*(idim+1)+j
  150.         ij0=(i-1)*idim+j
  151.         vpocha(i,j)=xcoor(ij)-mcoor1.xcoor(ij)
  152.         if(mrota.ne.0) vpocha(i,j+ncb)=xrota(ij0)-mrota1.xrota(ij0)
  153.        enddo
  154.        enddo
  155.        do i=1,min(nbpts,nbpts1)+1,nbpts
  156.        do j=1,idim
  157.         ij=(i-1)*(idim+1)+j
  158.         ij0=(i-1)*idim+j
  159.         vpocha(i,j)=xcoor(ij)
  160.         if(mrota.ne.0) vpocha(i,j+ncb)=xrota(ij0)
  161.        enddo
  162.        enddo
  163.       else                        
  164.        do i=1,min(nbpts,nbpts1)
  165.        do j=1,idim
  166.         ij=(i-1)*(idim+1)+j
  167.         ij0=(i-1)*idim+j
  168.         vpocha(i,j)=mcoor1.xcoor(ij)-xcoor(ij)
  169.         if(mrota.ne.0) vpocha(i,j+ncb)=mrota1.xrota(ij0)-xrota(ij0)
  170.        enddo
  171.        enddo
  172.        do i=1,min(nbpts,nbpts1)+1,nbpts
  173.        do j=1,idim
  174.         ij=(i-1)*(idim+1)+j
  175.         ij0=(i-1)*idim+j
  176.         vpocha(i,j)=                -xcoor(ij)
  177.         if(mrota.ne.0) vpocha(i,j+ncb)=                 -xrota(ij0)
  178.        enddo
  179.        enddo
  180.        endif
  181.        nbnn=1
  182.        nbelem=nbpts       
  183.        nbsous=0
  184.        nbref=0
  185.        segini meleme
  186.        itypel=1
  187.        do i=1,nbelem
  188.          num(1,i)=i
  189.        enddo
  190.        igeoc=meleme
  191.       endif
  192.       segdes mcoor1
  193.       segact mchpoi
  194. ***   call ecchpo(mchpoi,0)
  195.  
  196. *as xfem 2010_01_13
  197.       if (ierr.ne.0) then
  198.         if (ichax1.ne.0) then
  199.           write(ioimp,*) 'pr un deplacement enrichi, on a besoin du ',
  200.      &       'deplacement entre la config. 0 et la config. de reference'
  201.           return
  202.         endif
  203.       endif
  204. C
  205.       MMODEL = IPMODL
  206.       NBPART = KMODEL(/1)
  207.       IPICA = 0
  208.       DO 4 IPART=1,NBPART
  209.         IMODEL = KMODEL(IPART)
  210. C Pour certains modeles (OTTOSEN, UO2), les operateurs PICA et CAPI ne
  211. C doivent pas modifier les champs !
  212. * septembre 2019: cette restriction est enlevee
  213. **      IF ( INATUU.EQ.42 .OR. INATUU.EQ.108 ) IPICA = IPICA+1
  214. C Pour les modeles utilisateur UMAT, les contraintes sont deja de Cauchy
  215. C et ne doivent donc pas etre transportees !
  216.         IF ( INATUU.EQ.-1) IPICA = IPICA+1
  217. C Verification presence XFEM
  218. *as xfem 2010_01_13
  219.         NOBMO1=IVAMOD(/1)
  220.         if (NOBMO1.ne.0) then
  221.           Do iobmo1=1,NOBMO1
  222.             if (TYMODE(iobmo1).eq.'MCHAML') then
  223.               MCHEX1=IVAMOD(iobmo1)
  224.               if (MCHEX1.TITCHE .eq. 'ENRICHIS') then
  225.                 ICHAX1 = MCHEX1.ICHAML(1)
  226.                 goto 3
  227.               endif
  228.             endif
  229.           Enddo
  230.         endif
  231.  3      CONTINUE
  232. *fin as xfem 2010_01_13
  233.  4    CONTINUE
  234.  
  235. C Presence XFEM -> pointeur ICHAX1 non nul
  236. *as xfem 2010_01_13
  237.       if (ichax1.ne.0 .and. ipchp0.EQ.0) then
  238.         write(ioimp,*) 'pr un deplacement enrichi, on a besoin du ',
  239.      &      'deplacement entre la config. 0 et la config. de reference'
  240.         CALL ERREUR(21)
  241.         return
  242.       endif
  243.  
  244. C IPICA = NBPART -> Le modele entier contient des modeles UMAT
  245. C                   Recopie MCHAML IPCHE1 tel quel et on quitte
  246.       IF (IPICA.EQ.NBPART) THEN
  247.         IRET = 1
  248.         CALL COPIE8(IPCHE1,IPCHE2)
  249. C
  250. C Melange de MODELEs : Traitement GENERAL
  251. C
  252.       ELSE
  253.         IRET = 0
  254.         mchelm=ipche1
  255.         segact mchelm*mod
  256.         if (.not.caract) then
  257. **    write (6,*) 'mcoors mcoord avant piocap',mcoors,mcoord,mchelm
  258.         mclcnf=mcoord
  259.         segact mcoord
  260.         nbpts=xcoor(/1)/(idim+1)
  261.         CALL PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,IM,IDERI,
  262.      &              IPCHE2,IRET)
  263.         mchelm=ipche2
  264. **    write (6,*) 'mclcnf mcoord apres piocap',mclcnf,mcoord,mchelm
  265.         else
  266. C       Mise a jour des caracteristiques materielles
  267. **    write (6,*) 'mclcnf mcoord avant formch',mclcnf,mcoord,mchelm
  268.         CALL FORMCH(IPMODL,IPCHE1,IPCHP1,iret,IPCHe2)
  269.         mchelm=ipche2
  270.         segact mchelm*mod
  271.         mclcnf=mcoord
  272. **    write (6,*) 'mclcnf mcoord apres formch',mclcnf,mcoord,mchelm
  273.         endif
  274.         segact mcoord
  275.         nbpts=xcoor(/1)/(idim+1)
  276.         segdes mcoord
  277. **      call verrou(3)
  278.       ENDIF
  279.  
  280.       IF (IRET.EQ.1) THEN
  281. **      write(6,*) 'sortie de config ',ipche2
  282.         CALL ACTOBJ('MCHAML  ',IPCHE2,2)
  283.         CALL ECROBJ('MCHAML  ',IPCHE2)
  284.       ENDIF
  285.  
  286.       END
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  

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