Télécharger la plaquette Cast3M


fr en

Télécharger critp.eso

Retour à la liste

Numérotation des lignes : 

critp

  1. C CRITP     SOURCE    OF166741  25/11/04    21:15:39     12349          
  2.       SUBROUTINE CRITP(IPMODL,IPCHE1,IPCHE2,IPCAR,IPCHE3)
  3. *******************************************************************
  4. *
  5. *      CALCUL LE CRITERE DE PLASTICITE
  6. *
  7. **********************************************************************
  8. *
  9. *  ENTREES:
  10. *
  11. *  IPMODL = POINTEUR SUR UN OBJET MMODEL
  12. *  IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES
  13. *  IPCHE2 = POINTEUR SUR UN MCHAML DE VARIABLES INTERNES
  14. *  IPCAR  =  POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  15. *
  16. * SORTIES:
  17. *
  18. *  IPCHE3 = POINTEUR SUR UN MCHAML SCALAIRE
  19. *
  20. ************************************************************************
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCHAMP
  27.  
  28. -INC SMCHAML
  29. -INC SMELEME
  30. -INC SMCOORD
  31. -INC SMMODEL
  32. -INC SMINTE
  33.  
  34. C----------------------------------------------------------------------
  35. C   KERRE REGIT LES MESSAGES D'ERREUR DANS CRIT
  36. C
  37. C     =  0 TOUT OK
  38. C     =  1 ET 2   S ALIGNER SUR LES VALEURS DONNEES PAR ECOCRI
  39. C     =   7  UN ELEMENT TUYAU A UNE EPAISSEUR NULLE
  40. C
  41. C             ANOMALIES AVEC LA COURBE DE TRACTION
  42. C     =  30 LIMITE ELASTIQUE NULLE
  43. C     =  31 TROP DE POINTS
  44. C     =  32 PAS ASSEZ DE POINTS
  45. C     =  33 PENTE INCORRECTE
  46. C     =  34 MODULE D'YOUNG NUL
  47. C     =  35 MANQUE L'ORIGINE
  48. C     =  36 PENTE A L'ORIGINE NON EGALE A E
  49. C     =  37 MANQUE LA COURBE DE TRACTION
  50. C     =  48 DONNEES DRUCKER-PRAGER ERRONNEES
  51. C     =  99 CAS NON ENCORE DISPONIBLE
  52. C----------------------------------------------------------------------
  53.  
  54. -INC TMPTVAL
  55. -INC TECOU
  56.  
  57.       SEGMENT NOTYPE
  58.         CHARACTER*16 TYPE(NBTYPE)
  59.       ENDSEGMENT
  60.  
  61.       SEGMENT WRK0
  62.        REAL*8 XMAT(NCXMA0)
  63.       ENDSEGMENT
  64.  
  65.       SEGMENT WRK1
  66.         REAL*8 DDHOOK(NSTRS,NSTRS),SIG0(NSTRS),DSIGT(NSTRS)
  67.         REAL*8 SIGF(NSTRS),VAR0(NVARI),VARF(NVARI)
  68.         REAL*8 DEFP(NSTRS),XCAR(NCART)
  69.       ENDSEGMENT
  70.  
  71.       SEGMENT WRK2
  72.         REAL*8 TRAC(LTRAC2)
  73.       ENDSEGMENT
  74.  
  75.       SEGMENT WRK3
  76.         REAL*8 WORK(LW),WORK2(LW2)
  77.       ENDSEGMENT
  78.  
  79.       SEGMENT WRK4
  80.         REAL*8 XE(3,NBB4)
  81.       ENDSEGMENT
  82.  
  83.       DIMENSION MOMAT(2)
  84.       DIMENSION XEPOU(2),YEPOU(2),ZEPOU(2)
  85.       DIMENSION BID(3)
  86.  
  87.       CHARACTER*8 CMATE
  88.       CHARACTER*(NCONCH) CONM
  89.       PARAMETER ( NINF=3 )
  90.       INTEGER INFOS(NINF)
  91.  
  92.       DATA IUN,IZERO/1,0/
  93.       DATA UN,XZER,UNDEMI/1.D0,0.D0,.5D0/
  94. C
  95. C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES
  96. C
  97.       CALL QUESUP(IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  98.       IF (ISUP1.GT.1) RETURN
  99. C
  100. C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE VARIABLES INTERNES
  101. C
  102.       CALL  QUESUP(IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  103.       IF (ISUP2.GT.1) RETURN
  104. C
  105. C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  106. C
  107.       CALL  QUESUP(IPMODL,IPCAR,5,0,ISUP3,IRET3)
  108.       IF (ISUP3.GT.1) RETURN
  109. C
  110. C     ACTIVATION DU MODELE
  111. C
  112.       MMODEL=IPMODL
  113.       NSOUS=KMODEL(/1)
  114. C
  115. C     CREATION DU MCHAML
  116. C
  117.       N1=NSOUS
  118.       L1=8
  119.       N3=6
  120.       SEGINI MCHELM
  121.       TITCHE='SCALAIRE'
  122.       IFOCHE=IFOUR
  123.  
  124. C- Un petit segment utile
  125.       NBTYPE=1
  126.       SEGINI NOTYPE
  127.       notype.TYPE(1)='REAL*8'
  128.       MOTYR8=NOTYPE
  129. C____________________________________________________________________
  130. C
  131. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  132. C____________________________________________________________________
  133. C
  134.       DO 500 ISOUS=1,NSOUS
  135. *
  136. *   INITIALISATION
  137. *
  138.       NSTR=0
  139.       MOSTRS=0
  140.       IVASTR=0
  141.       MOVARI=0
  142.       NVARI=0
  143.       IVARI=0
  144.       NCARA=0
  145.       NCARF=0
  146.       MOCARA=0
  147.       IVACAR=0
  148.       NMATF=0
  149.       NMATR=0
  150.       MOMATR=0
  151.       IVAMAT=0
  152.       IMELCR=0
  153.       KERRE=0
  154. C
  155. C     ON RECUPERE L INFORMATION GENERALE
  156. C
  157.       IMODEL=KMODEL(ISOUS)
  158.       IPMAIL=IMAMOD
  159.       CONM  =CONMOD
  160.       IMACHE(ISOUS)=IPMAIL
  161.       CONCHE(ISOUS)=CONMOD
  162.  
  163.       MELE=NEFMOD
  164.       MELEME=IMAMOD
  165.  
  166.       NBNN=NUM(/1)
  167.       NBELEM=NUM(/2)
  168. C
  169. C     TRAITEMENT DU MODELE
  170. C
  171. C   COQUE INTEGREE OU PAS ?
  172.         NPINT=INFMOD(1)
  173.         IF (NPINT.NE.0)THEN
  174.           CALL ERREUR(615)
  175.           SEGSUP MCHELM
  176.           RETURN
  177.         ENDIF
  178. C
  179. C     NATURE DU MATERIAU
  180. C
  181.       CMATE  = CMATEE
  182.       MATE   = IMATEE
  183.       INPLAS = INATUU
  184. C____________________________________________________________________
  185. C
  186. C     INFORMATION SUR L'ELEMENT FINI
  187. C____________________________________________________________________
  188. C
  189.       MFR  =INFELE(13)
  190.       NBG  =INFELE(6)
  191.       NBGS =INFELE(4)
  192.       NSTRS=INFELE(16)
  193.       LRE  =INFELE(9)
  194.       IPPORE=0
  195.       IF (MFR.EQ.33) IPPORE=NBNN
  196.       LW  = 200
  197.       LW2 = 150
  198.       IPMINT=infmod(7)
  199. *
  200. *   REMPLISSAGE DES TABLEAUX INFCHE
  201. *
  202.       INFCHE(ISOUS,1)=0
  203.       INFCHE(ISOUS,2)=0
  204.       INFCHE(ISOUS,3)=NIFOUR
  205.       INFCHE(ISOUS,4)=IPMINT
  206.       INFCHE(ISOUS,5)=0
  207.       INFCHE(ISOUS,6)=5
  208. C
  209. C     CREATION DU TABLEAU INFOS
  210. C
  211.       CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  212.       IF (IRTD.EQ.0) RETURN
  213.  
  214. *
  215. *       TRAITEMENT DU CHAMP DE CONTRAINTES
  216. *
  217.         mostrs=lnomid(4)
  218.         IF (MOSTRS.EQ.0) THEN
  219.             MOTERR(1:4)='CONT'
  220.             MOTERR(5:8)=NOMTP(MELE)
  221.             CALL ERREUR(76)
  222.             RETURN
  223.         ENDIF
  224.         nomid=mostrs
  225.         nstr=lesobl(/2)
  226.         nfac=lesfac(/2)
  227.  
  228.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYR8,1,INFOS,3,IVASTR)
  229.          IF(IERR.NE.0)THEN
  230.             KERRE=999
  231.             GOTO 9990
  232.          ENDIF
  233.  
  234.         IF (ISUP1.EQ.1) THEN
  235.            CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  236.            IF(IERR.NE.0)THEN
  237.              KERRE=999
  238.              ISUP1=0
  239.              GOTO 9990
  240.             ENDIF
  241.         ENDIF
  242. *
  243. *       TRAITEMENT DU CHAMP DE VARIABLES INTERNES
  244. *
  245.         movari=lnomid(10)
  246.          IF (MOVARI.EQ.0) THEN
  247.             MOTERR(1:4)='VARI'
  248.             MOTERR(5:8)=NOMTP(MELE)
  249.             CALL ERREUR (76)
  250.             KERRE=999
  251.             GOTO 9990
  252.          ENDIF
  253.          nomid=movari
  254.          nvari=lesobl(/2)
  255.          nvarf=lesfac(/2)
  256.  
  257.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOVARI,MOTYR8,1,INFOS,3,IVARI)
  258.          IF(IERR.NE.0)THEN
  259.             KERRE=999
  260.             GOTO 9990
  261.          ENDIF
  262. *
  263.         IF (ISUP2.EQ.1) THEN
  264.            CALL VALCHE(IVARI,NVARI,IPMINT,IPPORE,MOVARI,MELE)
  265.            IF(IERR.NE.0)THEN
  266.              KERRE=999
  267.              ISUP2=0
  268.              GOTO 9990
  269.             ENDIF
  270.         ENDIF
  271. *
  272. *   TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES
  273. *
  274.         momatr=lnomid(6)
  275.          IF (MOMATR.EQ.0) THEN
  276.             MOTERR(1:4)='MATE'
  277.             MOTERR(5:8)=NOMTP(MELE)
  278.             CALL ERREUR (76)
  279.             KERRE=999
  280.             GOTO 9990
  281.          ENDIF
  282.          nomid = momatr
  283.          nmatr=lesobl(/2)
  284.          nmatf=lesfac(/2)
  285.          NMATT=NMATR+NMATF
  286.  
  287.          NBTYPE = 1
  288.          NOTYPE = MOTYR8
  289.          IF(INPLAS.EQ.5)THEN
  290.             NBTYPE=5
  291.             SEGINI NOTYPE
  292.             TYPE(1)='REAL*8'
  293.             TYPE(2)='REAL*8'
  294.             TYPE(3)='POINTEUREVOLUTIO'
  295.             TYPE(4)='REAL*8'
  296.             TYPE(5)='REAL*8'
  297.          ELSE IF (INPLAS.EQ.14) THEN
  298.             NBTYPE=9
  299.             SEGINI NOTYPE
  300.             TYPE(1)='REAL*8'
  301.             TYPE(2)='REAL*8'
  302.             TYPE(3)='REAL*8'
  303.             TYPE(4)='REAL*8'
  304.             TYPE(5)='REAL*8'
  305.             TYPE(6)='POINTEUREVOLUTIO'
  306.             TYPE(7)='POINTEUREVOLUTIO'
  307.             TYPE(8)='REAL*8'
  308.             TYPE(9)='REAL*8'
  309.          ELSE IF (INPLAS.EQ.26) THEN
  310.             NBTYPE=8
  311.             SEGINI NOTYPE
  312.             TYPE(1)='REAL*8'
  313.             TYPE(2)='REAL*8'
  314.             TYPE(3)='POINTEUREVOLUTIO'
  315.             TYPE(4)='REAL*8'
  316.             TYPE(5)='REAL*8'
  317.             TYPE(6)='REAL*8'
  318.             TYPE(7)='REAL*8'
  319.             TYPE(8)='REAL*8'
  320.          ELSEIF(INPLAS.EQ.29)THEN
  321.             NBTYPE=13
  322.             SEGINI NOTYPE
  323.             TYPE(1)='REAL*8'
  324.             TYPE(2)='REAL*8'
  325.             TYPE(3)='REAL*8'
  326.             TYPE(4)='REAL*8'
  327.             TYPE(5)='REAL*8'
  328.             TYPE(6)='REAL*8'
  329.             TYPE(7)='REAL*8'
  330.             TYPE(8)='REAL*8'
  331.             TYPE(9)='REAL*8'
  332.             TYPE(10)='POINTEUREVOLUTIO'
  333.             TYPE(11)='REAL*8'
  334.             TYPE(12)='REAL*8'
  335.             TYPE(13)='REAL*8'
  336.          ELSEIF(INPLAS.EQ.16)THEN
  337.             NBTYPE=7
  338.             SEGINI NOTYPE
  339.             TYPE(1)='REAL*8'
  340.             TYPE(2)='REAL*8'
  341.             TYPE(3)='POINTEUREVOLUTIO'
  342.             TYPE(4)='REAL*8'
  343.             TYPE(5)='REAL*8'
  344.             TYPE(6)='REAL*8'
  345.             TYPE(7)='REAL*8'
  346.          ELSEIF(INPLAS.EQ.2)THEN
  347.             NBTYPE=6
  348.             SEGINI NOTYPE
  349.             TYPE(1)='REAL*8'
  350.             TYPE(2)='REAL*8'
  351.             TYPE(3)='REAL*8'
  352.             TYPE(4)='POINTEUREVOLUTIO'
  353.             TYPE(5)='REAL*8'
  354.             TYPE(6)='REAL*8'
  355.          ENDIF
  356.          MOTYMA=NOTYPE
  357.          CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYMA,1,
  358.      &                                   INFOS,3,IVAMAT)
  359.          IF (MOTYMA.NE.MOTYR8) SEGSUP,NOTYPE
  360.          IF(IERR.NE.0)THEN
  361.             KERRE=999
  362.             GOTO 9990
  363.          ENDIF
  364.  
  365.         IF (ISUP3.EQ.1) THEN
  366.            CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  367.            IF(IERR.NE.0)THEN
  368.               KERRE=999
  369.               ISUP3=0
  370.               GOTO 9990
  371.            ENDIF
  372.         ENDIF
  373. *
  374. *      TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES
  375. *
  376.          NBROBL=0
  377.          NBRFAC=0
  378.          NOMID =0
  379.          NOTYPE = MOTYR8
  380. *
  381. *       COQUES MINCES
  382. *
  383.          IF (MFR.EQ.3.OR.MFR.EQ.9) THEN
  384.             NBROBL=1
  385.             NBRFAC=2
  386.             SEGINI NOMID
  387.             LESOBL(1)='EPAI'
  388.             LESFAC(1)='CALF'
  389.             LESFAC(2)='EXCE'
  390.  
  391.          ELSEIF (MFR.EQ.5) THEN
  392.             NBROBL=1
  393.             NBRFAC=1
  394.             SEGINI NOMID
  395.             LESOBL(1)='EPAI'
  396.             LESFAC(1)='EXCE'
  397. *
  398. * SECTION POUR LES BARRES
  399. *
  400.          ELSE IF (MFR.EQ.27) THEN
  401.             NBROBL=1
  402.             SEGINI NOMID
  403.             LESOBL(1)='SECT'
  404. *
  405. * CARACTERISTIQUES POUR LES POUTRES
  406. *
  407.          ELSE IF (MFR.EQ.7 ) THEN
  408.             NBROBL=4
  409.             NBRFAC=8
  410.             SEGINI NOMID
  411.             LESOBL(1)='TORS'
  412.             LESOBL(2)='INRY'
  413.             LESOBL(3)='INRZ'
  414.             LESOBL(4)='SECT'
  415.             LESFAC(1)='SECY'
  416.             LESFAC(2)='SECZ'
  417.             LESFAC(3)='DX  '
  418.             LESFAC(4)='DY  '
  419.             LESFAC(5)='DZ  '
  420.             LESFAC(6)='VX'
  421.             LESFAC(7)='VY'
  422.             LESFAC(8)='VZ'
  423. *
  424. * CARACTERISTIQUES POUR LES TUYAUX
  425. *
  426.          ELSE IF (MFR.EQ.13) THEN
  427.             NBROBL=2
  428.             NBRFAC=11
  429.             SEGINI NOMID
  430.             LESOBL(1)='EPAI'
  431.             LESOBL(2)='RAYO'
  432.             LESFAC(1)='RACO'
  433.             LESFAC(2)='PRES'
  434.             LESFAC(3)='CISA'
  435.             LESFAC(4)='CFFX'
  436.             LESFAC(5)='CFMX'
  437.             LESFAC(6)='CFMY'
  438.             LESFAC(7)='CFMZ'
  439.             LESFAC(8)='CFPR'
  440.             LESFAC(9)='VX'
  441.             LESFAC(10)='VY'
  442.             LESFAC(11)='VZ'
  443. *
  444. * CARACTERISTIQUES POUR LES LINESPRING
  445. *
  446.          ELSE IF (MFR.EQ.15) THEN
  447.             NBROBL=5
  448.             SEGINI NOMID
  449.             LESOBL(1)='EPAI'
  450.             LESOBL(2)='FISS'
  451.             LESOBL(3)='VX  '
  452.             LESOBL(4)='VY  '
  453.             LESOBL(5)='VZ  '
  454. *
  455. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  456. *
  457.          ELSE IF (MFR.EQ.17) THEN
  458.             NBROBL=9
  459.             SEGINI NOMID
  460.             LESOBL(1)='RAYO'
  461.             LESOBL(2)='EPAI'
  462.             LESOBL(3)='VX  '
  463.             LESOBL(4)='VY  '
  464.             LESOBL(5)='VZ  '
  465.             LESOBL(6)='VXF '
  466.             LESOBL(7)='VYF '
  467.             LESOBL(8)='VZF '
  468.             LESOBL(9)='ANGL'
  469. *
  470. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  471. *
  472.          ELSE IF (MFR.EQ.37) THEN
  473.             IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  474.                NBROBL=4
  475.                SEGINI NOMID
  476.                LESOBL(1)='SCEL'
  477.                LESOBL(2)='SFLU'
  478.                LESOBL(3)='EPS '
  479.                LESOBL(4)='XINE'
  480.             ELSE
  481.                NBROBL=3
  482.                SEGINI NOMID
  483.                LESOBL(1)='SCEL'
  484.                LESOBL(2)='SFLU'
  485.                LESOBL(3)='EPS '
  486.             ENDIF
  487.          ENDIF
  488. *
  489.          MOCARA=NOMID
  490.          NCARA=NBROBL
  491.          NCARF=NBRFAC
  492.          NCARR=NCARA+NCARF
  493.  
  494.          NCART=NCARR
  495.          IF (MFR.EQ.7.OR.MFR.EQ.13) NCART=NCARR+IDIM-3
  496.  
  497.          IF(MOCARA.NE.0)THEN
  498.             MOTYCA=NOTYPE
  499.             CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYCA,1,
  500.      &                                     INFOS,3,IVACAR)
  501.             IF (MOTYCA.NE.MOTYR8) SEGSUP NOTYPE
  502.             IF(IERR.NE.0)THEN
  503.                KERRE=999
  504.                GOTO 9990
  505.             ENDIF
  506.  
  507.            IF (ISUP3.EQ.1) THEN
  508.                CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  509.                IF(IERR.NE.0)THEN
  510.                   KERRE=999
  511.                   ISUP3=0
  512.                   GOTO 9990
  513.                ENDIF
  514.            ENDIF
  515.          ENDIF
  516. *
  517. *      CREATION DES MCHAMLS DE LA SOUS ZONE
  518. *
  519.        NBPTEL=NBGS
  520.        NEL   =NBELEM
  521.        N1PTEL=NBPTEL
  522.        N1EL  =NEL
  523.        N2PTEL=0
  524.        N2EL  =0
  525.  
  526.        N2=1
  527.        SEGINI MCHAML
  528.        ICHAML(ISOUS)=MCHAML
  529.        NOMCHE(1)='SCAL'
  530.        TYPCHE(1)='REAL*8'
  531.  
  532.        SEGINI MELVAL
  533.        IELVAL(1)=MELVAL
  534.        IMELCR=MELVAL
  535.  
  536. C    MISE A 0 DES VARIABLES DU COMMON NECOU SI BESOIN
  537. C    LES BONNES VALEURS SONT ATTRIBUEES SELON LES MODELES
  538. C    INITIALISATIONS SELON LES CAS
  539. C
  540.       SEGINI,necou,ecou
  541.  
  542.       LTRAC2=0
  543.       IF (INPLAS.NE.2)THEN
  544.        IFOURB=IFOUR
  545.        NCOURB=0
  546.        IPLAST=0
  547.        IMAPLA=1
  548.        IT=1
  549.        ISOTRO=0
  550.        ITYP=0
  551. C
  552. C  CORRESPONDANCE ( MFR,IFOUR) ET ITYP FAITE DANS ECOCRI
  553. C
  554.        IFLUAG=0
  555.        ICINE=0
  556.        ITHER=0
  557.        IFLUPL=0
  558.        ICYCL=0
  559.        JFLUAG=0
  560.        KFLUAG=0
  561.        LFLUAG=0
  562.        IRELAX=0
  563.        JNTRIN=0
  564.        MFLUAG=0
  565.        JSOUFL=0
  566.        JGRDEF=0
  567.        LTRAC2=60
  568.       ENDIF
  569. *
  570. *    INITIALISATION DES SEGMENTS DE TRAVAIL
  571. *
  572.       NCXMA0=NMATT
  573.       IF (INPLAS.EQ.3) NCXMA0=NMATT+7
  574.       SEGINI,WRK0,WRK1,WRK2,WRK3
  575.       IF (MFR.EQ.7.OR.MFR.EQ.13) THEN
  576.          NBB4=NBNN
  577.          SEGINI WRK4
  578.       ENDIF
  579. *
  580. *       BOUCLE SUR LES ELEMENTS
  581. *
  582.        DO 200 IB=1,NBELEM
  583. *
  584. *       BOUCLE SUR LES POINTS DE GAUSS
  585. *
  586.          DO 300  IGAU=1,NBPTEL
  587. *
  588. *       ON RECUPERE LES CONTRAINTES
  589. *
  590.             MPTVAL=IVASTR
  591.             DO 201 IC=1,NSTRS
  592.                MELVAL=IVAL(IC)
  593.                IBMN=MIN(IB,VELCHE(/2))
  594.                IGMN=MIN(IGAU,VELCHE(/1))
  595.                SIG0(IC)=VELCHE(IGMN,IBMN)
  596.  201         CONTINUE
  597. *
  598. *     ON RECUPERE LES VARIABLES INTERNES
  599. *
  600.             MPTVAL=IVARI
  601.             DO 202 IC=1,NVARI
  602.                MELVAL=IVAL(IC)
  603.                IBMN=MIN(IB,VELCHE(/2))
  604.                IGMN=MIN(IGAU,VELCHE(/1))
  605.                VAR0(IC)=VELCHE(IGMN,IBMN)
  606.  202         CONTINUE
  607. *
  608. *     ON RECUPERE LES CONSTANTES DU MATERIAU
  609. *
  610.             MPTVAL=IVAMAT
  611.             IF(INPLAS.EQ.9 .OR.INPLAS .EQ. 28)THEN
  612. *
  613. *         POUR LE MODELE BETON ET UBIQUITOUS
  614. *
  615.                DO 203 IC=1,NMATT
  616.                   MELVAL=IVAL(IC)
  617.                   IF(MELVAL.NE.0)THEN
  618.                      IBMN=MIN(IB,VELCHE(/2))
  619.                      IGMN=MIN(IGAU,VELCHE(/1))
  620.                      XMAT(IC)=VELCHE(IGMN,IBMN)
  621.                   ELSE
  622.                      XMAT(IC)=0.D0
  623.                   ENDIF
  624.  203            CONTINUE
  625.             ELSE
  626. *
  627. *         POUR LES AUTRES MODELES
  628. *
  629.                MELVAL=IVAL(1)
  630.                IF(MELVAL.NE.0)THEN
  631.                   IF(TYVAL(1)(1:8).NE.'POINTEUR')THEN
  632.                      IBMN=MIN(IB,VELCHE(/2))
  633.                      IGMN=MIN(IGAU,VELCHE(/1))
  634.                      XMAT(1)=VELCHE(IGMN,IBMN)
  635.                   ELSE
  636.                      IBMN=MIN(IB,IELCHE(/2))
  637.                      IGMN=MIN(IGAU,IELCHE(/1))
  638.                      XMAT(1)=IELCHE(IGMN,IBMN)
  639.                   ENDIF
  640.                ELSE
  641.                   XMAT(1)=0.D0
  642.                   IF(TYVAL(1)(1:8).EQ.'POINTEUR') THEN
  643.                      XMAT(1)=0
  644.                   END IF
  645.                ENDIF
  646.                MELVAL=IVAL(2)
  647.                IF(MELVAL.NE.0)THEN
  648.                   IF(TYVAL(2)(1:8).NE.'POINTEUR')THEN
  649.                      IBMN=MIN(IB,VELCHE(/2))
  650.                      IGMN=MIN(IGAU,VELCHE(/1))
  651.                      XMAT(2)=VELCHE(IGMN,IBMN)
  652.                   ELSE
  653.                      IBMN=MIN(IB,IELCHE(/2))
  654.                      IGMN=MIN(IGAU,IELCHE(/1))
  655.                      XMAT(2)=IELCHE(IGMN,IBMN)
  656.                   ENDIF
  657.                ELSE
  658.                   XMAT(2)=0.D0
  659.                   IF(TYVAL(2)(1:8).EQ.'POINTEUR') THEN
  660.                      XMAT(2)=0
  661.                   END IF
  662.                ENDIF
  663.                DO 205 IC=3,NMATT-2
  664.                   MELVAL=IVAL(IC)
  665.                   IF(MELVAL.NE.0)THEN
  666.                      IF(TYVAL(IC)(1:8).NE.'POINTEUR')THEN
  667.                         IBMN=MIN(IB,VELCHE(/2))
  668.                         IGMN=MIN(IGAU,VELCHE(/1))
  669.                         XMAT(IC+2)=VELCHE(IGMN,IBMN)
  670.                      ELSE
  671.                        IBMN=MIN(IB,IELCHE(/2))
  672.                        IGMN=MIN(IGAU,IELCHE(/1))
  673.                        XMAT(IC+2)=IELCHE(IGMN,IBMN)
  674.                      ENDIF
  675.                   ELSE
  676.                      XMAT(IC+2)=0.D0
  677.                      IF(TYVAL(IC)(1:8).EQ.'POINTEUR') THEN
  678.                         XMAT(IC+2)=0
  679.                      END IF
  680.                   ENDIF
  681.  205            CONTINUE
  682.                MELVAL=IVAL(NMATT-1)
  683.                IF(MELVAL.NE.0)THEN
  684.                   IF(TYVAL(NMATT-1)(1:8).NE.'POINTEUR')THEN
  685.                      IBMN=MIN(IB,VELCHE(/2))
  686.                      IGMN=MIN(IGAU,VELCHE(/1))
  687.                      XMAT(3)=VELCHE(IGMN,IBMN)
  688.                   ELSE
  689.                      IBMN=MIN(IB,IELCHE(/2))
  690.                      IGMN=MIN(IGAU,IELCHE(/1))
  691.                      XMAT(3)=IELCHE(IGMN,IBMN)
  692.                   ENDIF
  693.                ELSE
  694.                   XMAT(3)=0.D0
  695.                   IF(TYVAL(NMATT-1)(1:8).EQ.'POINTEUR')XMAT(3)=0
  696.                END IF
  697.                MELVAL=IVAL(NMATT)
  698.                IF(MELVAL.NE.0)THEN
  699.                   IF(TYVAL(NMATT)(1:8).NE.'POINTEUR')THEN
  700.                      IBMN=MIN(IB,VELCHE(/2))
  701.                      IGMN=MIN(IGAU,VELCHE(/1))
  702.                      XMAT(4)=VELCHE(IGMN,IBMN)
  703.                   ELSE
  704.                      IBMN=MIN(IB,IELCHE(/2))
  705.                      IGMN=MIN(IGAU,IELCHE(/1))
  706.                      XMAT(4)=IELCHE(IGMN,IBMN)
  707.                   ENDIF
  708.                ELSE
  709.                   XMAT(4)=0.D0
  710.                   IF(TYVAL(NMATT)(1:8).EQ.'POINTEUR') THEN
  711.                      XMAT(4)=0
  712.                   END IF
  713.                ENDIF
  714. *
  715. *        REARRANGEMENT POUR  CERTAINES LOIS
  716. *
  717.                IF (INPLAS.EQ.14) THEN
  718.                   IF(XMAT(8).NE.XZER.OR.XMAT(9).NE.XZER)THEN
  719.                      INPLAS=18
  720.                      XMAT(5)=XMAT(8)
  721.                      XMAT(6)=XMAT(9)
  722.                   ENDIF
  723.                ELSE IF (INPLAS.EQ.2) THEN
  724.                   IF (XMAT(6).NE.XZER) THEN
  725.                      INPLAS=27
  726.                      XMAT(5)=XMAT(6)
  727.                   ENDIF
  728.                ELSE IF (INPLAS.EQ.29)THEN
  729.                   YXMAT=XMAT(13)
  730.                   XMAT(13)=XMAT(4)
  731.                   XMAT(4)=XMAT(3)
  732.                   XMAT(3)=YXMAT
  733.                ENDIF
  734.             ENDIF
  735. *
  736. *        ON RECUPERE LES CARACTERISTIQUES GEOMETRIQUES
  737. *
  738.             IF(IVACAR.NE.0)THEN
  739.                MPTVAL=IVACAR
  740. *
  741. * cas des tuyaux
  742. *
  743.                IF(MFR.EQ.13)THEN
  744.                   DO 106 IC=1,5
  745.                      MELVAL=IVAL(IC)
  746.                      IF(MELVAL.NE.0)THEN
  747.                         IBMN=MIN(IB,VELCHE(/2))
  748.                         IGMN=MIN(IGAU,VELCHE(/1))
  749.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  750.                      ELSE
  751.                         XCAR(IC)=0.D0
  752.                      ENDIF
  753.  106               CONTINUE
  754.                  IF(IVECT.NE.0)THEN
  755.                   DO 107 IC=6,NCARR
  756.                      MELVAL=IVAL(IC)
  757.                      IF(MELVAL.NE.0)THEN
  758.                         IBMN=MIN(IB,VELCHE(/2))
  759.                         IGMN=MIN(IGAU,VELCHE(/1))
  760.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  761.                      ELSE
  762.                         XCAR(IC)=-1.D0
  763.                      ENDIF
  764.  107               CONTINUE
  765.                  ELSE
  766.                   DO 110 IC=6,10
  767.                      MELVAL=IVAL(IC)
  768.                      IF(MELVAL.NE.0)THEN
  769.                         IBMN=MIN(IB,VELCHE(/2))
  770.                         IGMN=MIN(IGAU,VELCHE(/1))
  771.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  772.                      ELSE
  773.                         XCAR(IC)=-1.D0
  774.                      ENDIF
  775.  110               CONTINUE
  776.                   DO 111 IC=11,NCART
  777.                      MELVAL=IVAL(IC)
  778.                      IF(MELVAL.NE.0)THEN
  779.                         IBMN=MIN(IB,VELCHE(/2))
  780.                         IGMN=MIN(IGAU,VELCHE(/1))
  781.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  782.                      ELSE
  783.                         XCAR(IC)=0.D0
  784.                      ENDIF
  785.  111               CONTINUE
  786.                  ENDIF
  787.                ELSE IF(MFR.EQ.7.AND.IVECT.NE.0)THEN
  788.                   DO 206 IC=1,NCARR
  789.                      MELVAL=IVAL(IC)
  790.                      IF(MELVAL.NE.0)THEN
  791.                         IBMN=MIN(IB,VELCHE(/2))
  792.                         IGMN=MIN(IGAU,VELCHE(/1))
  793.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  794.                      ELSE
  795.                         XCAR(IC)=0.D0
  796.                      ENDIF
  797.  206               CONTINUE
  798.                ELSE
  799.                   DO 209 IC=1,NCART
  800.                      MELVAL=IVAL(IC)
  801.                      IF(MELVAL.NE.0)THEN
  802.                         IBMN=MIN(IB,VELCHE(/2))
  803.                         IGMN=MIN(IGAU,VELCHE(/1))
  804.                         XCAR(IC)=VELCHE(IGMN,IBMN)
  805.                      ELSE
  806.                         XCAR(IC)=0.D0
  807.                      ENDIF
  808.  209               CONTINUE
  809.                ENDIF
  810. *
  811. *    REARRANGEMENT DU TABLEAU XCAR POUR QU'ON AIT LA MEME ORDRE
  812. *    QUE L'ANCIEN  CHAMELEM
  813. *
  814.                IF(MFR.EQ.7)THEN
  815.                   IF(IDIM.EQ.2)THEN
  816.                      VX=XCAR(NCART-3)
  817.                      VY=XCAR(NCART-2)
  818.                      XCAR(NCART-3)=XCAR(NCART-1)
  819.                      XCAR(NCART-2)=XCAR(NCART)
  820.                      XCAR(NCART-1)=VX
  821.                      XCAR(NCART)=VY
  822.                   ELSEIF(IDIM.EQ.3)THEN
  823.                      VX=XCAR(NCART-5)
  824.                      VY=XCAR(NCART-4)
  825.                      VZ=XCAR(NCART-3)
  826.                      XCAR(NCART-5)=XCAR(NCART-2)
  827.                      XCAR(NCART-4)=XCAR(NCART-1)
  828.                      XCAR(NCART-3)=XCAR(NCART)
  829.                      XCAR(NCART-2)=VX
  830.                      XCAR(NCART-1)=VY
  831.                      XCAR(NCART)=VZ
  832.                   ENDIF
  833.                ELSE IF(MFR.EQ.13)THEN
  834.                   NWORK2 = 7
  835.                   DO 210 IC=4,10
  836.                   WORK2(IC-3)=XCAR(IC)
  837.  210              CONTINUE
  838.                   IF(IDIM.EQ.2)THEN
  839.                      XCAR(4)=XCAR(NCART-1)
  840.                      XCAR(5)=XCAR(NCART)
  841.                      DO 211 IC=1,NWORK2
  842.                      XCAR(IC+5)=WORK2(IC)
  843.  211                 CONTINUE
  844.                   ELSE IF(IDIM.EQ.3)THEN
  845.                      XCAR(4)=XCAR(NCART-2)
  846.                      XCAR(5)=XCAR(NCART-1)
  847.                      XCAR(6)=XCAR(NCART)
  848.                      DO 212 IC=1,NWORK2
  849.                      XCAR(IC+6)=WORK2(IC)
  850.  212                 CONTINUE
  851.                   ENDIF
  852.                ENDIF
  853.             ENDIF
  854. *
  855.        IF(INPLAS.EQ.0) THEN
  856.            CRITER = 0.D0
  857.           GOTO 510
  858. C
  859.        ELSE
  860. C=======================================================================
  861. C     NUMERO DES ETIQUETTES      :
  862. C
  863. C     1 A 99 POUR LES MODELES DE PLASTICITE  ( INDICE INPLAS )
  864. C
  865. C=======================================================================
  866.       GOTO (1, 2, 3, 4, 5,99, 7,99,99,99, 7, 7, 7,14,15) INPLAS
  867. C
  868.   99  CONTINUE
  869.       KERRE=999
  870.       MOTERR(1:4)=NOMAC(INPLAS)
  871.       MOTERR(5:12)=NOMFR(MFR)
  872.       CALL ERREUR(269)
  873.       GOTO 9991
  874. C
  875. C     MODELE VON MISES ISOTROPE ASSOCIE ( D'APRES INCA )
  876. C
  877.    1  CONTINUE
  878. C
  879. C    CAS DE LA PLASTICITE PARFAITE
  880. C
  881.       NCOURB=2
  882.       TRAC(1)=XMAT(5)
  883.       TRAC(2)=0.D0
  884.       TRAC(3)=XMAT(5)
  885.       TRAC(4)=1.D0
  886.       IF(XMAT(5).EQ.XZER) THEN
  887.       KERRE=33
  888.       GO TO 510
  889.       ENDIF
  890.       GOTO 682
  891. C
  892.    3  CONTINUE
  893. C
  894. C    CAS DU MODELE DE DRUCKER-PRAGER PARFAIT
  895. C  LES DONNEES SONT LES LIMITES EN TRACTION ET EN COMPRESSION
  896. C
  897.       IMAPLA=5
  898.       DEN =  ABS(XMAT(6)) + XMAT(5)
  899.       IF(DEN.EQ.0.D0) THEN
  900.       KERRE=48
  901.       GO TO 510
  902.       ENDIF
  903.       XMAT(7) = 2.0D0*ABS(XMAT(6))*XMAT(5)/DEN
  904.       XMAT(5) = (ABS(XMAT(6)) - XMAT(5))/DEN
  905.       XMAT(6) = SQRT(3.D0)
  906.       XMAT(8)=XMAT(5)
  907.       XMAT(9)=XMAT(6)
  908.       XMAT(10)=XMAT(5)
  909.       XMAT(11)=XMAT(6)
  910.       XMAT(12)=XMAT(7)
  911.       XMAT(13)=0.D0
  912. C          PETITS TESTS SUR LES DONNEES
  913.       IF(XMAT(10)/(XMAT(11)+1.D-20).GT.XMAT(5)*1.01/(XMAT(6)+1.D-20)
  914.      .   .OR.XMAT(12).GT.XMAT(7)*1.01 ) THEN
  915.       KERRE=48
  916.       GO TO 510
  917.       ENDIF
  918.       GOTO 682
  919. C
  920.    4  CONTINUE
  921. C
  922. C    CAS DE LA PLASTICITE CINEMATIQUE BILINEAIRE
  923. C
  924.       ICINE=1
  925.       NCOURB=2
  926.       TRAC(1)=XMAT(5)
  927.       TRAC(2)=0.D0
  928.       TRAC(3)=XMAT(5)+XMAT(6)
  929.       TRAC(4)=1.D0
  930.       IF(XMAT(5).EQ.0.D0) THEN
  931.       KERRE=33
  932.       GO TO 510
  933.       ENDIF
  934.       GOTO 682
  935. C
  936.    5  CONTINUE
  937. C
  938. C   CAS DE LA PLASTICITE ISOTROPE ECROUISSABLE
  939. C
  940. C  ON RECUPERE LA COURBE DE TRACTION
  941. C
  942.       nccor=ncourb
  943.       CALL COTRAC(WRK0,WRK2,nccor,KERRE)
  944.       ncourb=nccor
  945.       IF(KERRE.NE.0) GO TO 510
  946.       GO TO 682
  947. C
  948.    7  CONTINUE
  949. C
  950. C    CAS DU MODELE CHABOCHE
  951. C
  952.       ICINE=1
  953.       IMAPLA=4
  954.       GOTO 682
  955. C
  956.   15  CONTINUE
  957. C
  958. C    CAS DU MODELE DE DRUCKER-PRAGER GENERAL
  959. C
  960.       IMAPLA=5
  961. C          PETITS TESTS SUR LES DONNEES
  962.       IF(XMAT(10)/(XMAT(11)+1.D-20).GT.XMAT(5)*1.01/(XMAT(6)+1.D-20)
  963.      .   .OR.XMAT(12).GT.XMAT(7)*1.01 ) THEN
  964.       KERRE=48
  965.       GO TO 510
  966.       ENDIF
  967. C          PERMUTATIONS POUR ECOCRI
  968.       DO 615 I=5,7
  969.         WW=XMAT(I)
  970.         XMAT(I)=XMAT(I+5)
  971.         XMAT(I+5)=WW
  972.  615  CONTINUE
  973.       GOTO 682
  974. C
  975.   682 CONTINUE
  976.       DO 675 IC=1,NCART
  977.       WORK(IC)=XCAR(IC)
  978.   675 CONTINUE
  979.       BID(1)=0.D00
  980.       BID(2)=0.D00
  981.       BID(3)=0.D00
  982.       necobi=necou
  983.       neecbi=ecou
  984.       CALL ECOCRI(SIG0,VAR0,BID,XMAT,CRITER,WORK ,
  985.      .            TRAC,KERRE,MFR,NSTRS,INPLAS,necou,ecou)
  986.       IF(KERRE.EQ.99) GO TO 99
  987.       GOTO 510
  988. C
  989. C     MODELE LINESPRING
  990. C
  991.    2  CONTINUE
  992.       CALL LISCRI(SIG0,XMAT,XCAR,KERRE,CRITER)
  993.       GOTO 510
  994. C
  995. C     TUYAU FISSURE
  996. C
  997.   14  CONTINUE
  998.       CALL TUFCRI(SIG0,VAR0,XMAT,XCAR,KERRE,CRITER)
  999.       GOTO 510
  1000.       ENDIF
  1001. C
  1002.   510 CONTINUE
  1003. C
  1004. C     IMPRESSION DE QUELQUES  MESSAGES D ERREURS
  1005. C
  1006.       IF (KERRE.NE.0) THEN
  1007.       INTERR(1)=IB
  1008.       INTERR(2)=IGAU
  1009.       MOTERR(1:4)=NOMTP(MELE)
  1010.       IF(KERRE.EQ.1)  CALL ERREUR(267)
  1011.       IF(KERRE.EQ.2)  CALL ERREUR(268)
  1012.       IF(KERRE.EQ.7)  CALL ERREUR(355)
  1013.       IF(KERRE.EQ.30) CALL ERREUR(270)
  1014.       IF(KERRE.EQ.31) CALL ERREUR(271)
  1015.       IF(KERRE.EQ.32) CALL ERREUR(272)
  1016.       IF(KERRE.EQ.33) CALL ERREUR(273)
  1017.       IF(KERRE.EQ.34) CALL ERREUR(325)
  1018.       IF(KERRE.EQ.35) CALL ERREUR(331)
  1019.       IF(KERRE.EQ.36) CALL ERREUR(330)
  1020.       IF(KERRE.EQ.37) CALL ERREUR(354)
  1021.       IF(KERRE.EQ.38) CALL ERREUR(360)
  1022.       IF(KERRE.EQ.48) CALL ERREUR(366)
  1023.       IF(KERRE.EQ.75) CALL ERREUR(876)
  1024.       GO TO 9991
  1025.       ENDIF
  1026. C
  1027. C     REMPLISSAGE DU SEGMENT
  1028. C
  1029.        MELVAL=IMELCR
  1030.        VELCHE(IGAU,IB)=CRITER
  1031. C
  1032.  300  CONTINUE
  1033.  200  CONTINUE
  1034. *
  1035. *     DESACTIVATION DES SEGMENTS
  1036. *
  1037.  9991   CONTINUE
  1038.         SEGSUP WRK0,WRK1,WRK2,WRK3
  1039.         IF (MFR.EQ.7.OR.MFR.EQ.13) SEGSUP WRK4
  1040.         segsup necou,ecou
  1041.  
  1042.  9990 CONTINUE
  1043.          IF(ISUP1.EQ.1)THEN
  1044.             CALL DTMVAL (IVASTR,3)
  1045.          ELSE
  1046.             CALL DTMVAL (IVASTR,1)
  1047.          ENDIF
  1048.          IF(ISUP2.EQ.1)THEN
  1049.             CALL DTMVAL (IVARI,3)
  1050.          ELSE
  1051.             CALL DTMVAL (IVARI,1)
  1052.          ENDIF
  1053.          IF(ISUP3.EQ.1)THEN
  1054.             CALL DTMVAL (IVAMAT,3)
  1055.          ELSE
  1056.            CALL DTMVAL (IVAMAT,1)
  1057.          ENDIF
  1058.          IF(ISUP3.EQ.1)THEN
  1059.             CALL DTMVAL (IVACAR,3)
  1060.          ELSE
  1061.             CALL DTMVAL (IVACAR,1)
  1062.          ENDIF
  1063.  
  1064.          MELVAL=IMELCR
  1065.          IF (KERRE.EQ.0)THEN
  1066.            SEGDES MELVAL
  1067.            SEGDES MCHAML
  1068.          ELSE
  1069.            SEGSUP MELVAL
  1070.            SEGSUP MCHAML
  1071.            GO TO 888
  1072.          ENDIF
  1073. 500    CONTINUE
  1074.  
  1075. C- Fin :
  1076.  888  CONTINUE
  1077.       NOTYPE=MOTYR8
  1078.       SEGSUP,NOTYPE
  1079.  
  1080.       IF(KERRE.EQ.0)THEN
  1081.          IPCHE3=MCHELM
  1082.          SEGDES MCHELM
  1083.       ELSE
  1084.          SEGSUP MCHELM
  1085.       ENDIF
  1086.  
  1087.       RETURN
  1088.       END
  1089.  
  1090.  
  1091.  

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