Télécharger la plaquette Cast3M


fr en

Télécharger invaca.eso

Retour à la liste

Numérotation des lignes : 

invaca

  1. C INVACA    SOURCE    OF166741  24/10/07    21:15:29     12016          
  2.  
  3.       SUBROUTINE INVACA(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPCHE4,IPCHE5,
  4.      &                  IMIL,IRET)
  5.  
  6. *---------------------------------------------------------------------
  7. *
  8. *      CALCUL DES 3 INVARIANTS D'UN TENSEUR D'ORDRE 2
  9. *                 (APPELE PAR INVARI)
  10. *
  11. *   ENTREES:
  12. *   --------
  13. *
  14. *     IPMODL   POINTEUR SUR UN MMODEL
  15. *     IPCHE1   POINTEUR SUR UN CHAMELEM DE CONTRAINTES OU DEFORMATIONS
  16. *              (TYPE MCHAML)
  17. *     IPCHE5   POINTEUR SUR UN CHAMELEM DE CARACTERISTIQUES
  18. *              (TYPE MCHAML)
  19. *     IMIL     INDICATEUR OU ON CALCULE LES CONTRAINTES POUR
  20. *              LES COQUES
  21. *
  22. *  SORTIES :
  23. *  ---------
  24. *
  25. *     IPCHE2   POINTEUR SUR UN CHAMELEM STRESSES ( I1)
  26. *     IPCHE3   POINTEUR SUR UN CHAMELEM STRESSES ( I2 )
  27. *     IPCHE4   POINTEUR SUR UN CHAMELEM STRESSES ( I3 )
  28. *     IRET     =1  OU  0   SUIVANT SUCCES OU PAS
  29. *
  30. *  PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90
  31. *
  32. *---------------------------------------------------------------------
  33. *
  34.       IMPLICIT INTEGER(I-N)
  35.       IMPLICIT REAL*8(A-H,O-Z)
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCHAMP
  40. C==DEB= FORMULATION HHO == Include specifique ==========================
  41. -INC CCHHOPA
  42. C==FIN= FORMULATION HHO ================================================
  43.  
  44. -INC SMCHAML
  45. -INC SMMODEL
  46.  
  47.       SEGMENT NOTYPE
  48.         CHARACTER*16 TYPE(NBTYPE)
  49.       ENDSEGMENT
  50. *
  51.       SEGMENT MPTVAL
  52.         INTEGER IPOS(NS)    ,NSOF(NS)
  53.         INTEGER      IVAL(NCOSOU)
  54.         CHARACTER*16 TYVAL(NCOSOU)
  55.       ENDSEGMENT
  56. *
  57.       PARAMETER ( NINF=3 )
  58.       INTEGER INFOS(NINF)
  59.       CHARACTER*(NCONCH) CONM
  60.       LOGICAL lsupno
  61. *
  62.       DIMENSION SIG(9)
  63.  
  64. *------ Fin des déclarations ------------------------------------
  65.  
  66.       IRET = 0
  67.       IPCHE2 = 0
  68.       IPCHE3 = 0
  69.       IPCHE4 = 0
  70. *
  71. * Reduction des MCHAMLs sur le MODELE
  72. *
  73.       kerre = 0
  74. *
  75.       CALL REDUAF(IPCHE1,IPMODL,ipch,0,ir,kerre)
  76.       IF (ir.NE.1) CALL ERREUR(kerre)
  77.       IF (IERR.NE.0) RETURN
  78.       IPCHE1 = ipch
  79. *
  80.       IF (IPCHE5.NE.0) THEN
  81.         CALL REDUAF(IPCHE5,IPMODL,ipch,0,ir,kerre)
  82.         IF (ir.NE.1) CALL ERREUR(kerre)
  83.         IF (IERR.NE.0) RETURN
  84.         IPCHE5 = ipch
  85.       ENDIF
  86. *
  87. * Verification du type de IPCHE1 !
  88. *
  89.       MCHELM = IPCHE1
  90.       SEGACT,MCHELM
  91.       IF (TITCHE.EQ.'CONTRAINTES') THEN
  92.         ICONTR = 1
  93.         W1 = 2.D0
  94.         W2 = 1.D0
  95.         W3 = 2.D0
  96.       ELSE IF (TITCHE.EQ.'DEFORMATIONS') THEN
  97.         ICONTR = 0
  98.         W1 = 0.5D0
  99.         W2 = 0.25D0
  100.         W3 = 0.25D0
  101.       ELSE
  102.         MOTERR(1:24)='CONTRAINTES'
  103.         MOTERR(25:48)='DEFORMATIONS'
  104.         CALL ERREUR(109)
  105.         GOTO 666
  106.       ENDIF
  107. *
  108. *  Verification du lieu support des mchamls
  109. *
  110.       CALL QUESUP(IPMODL,IPCHE1,0,0,iret1,ISUP1)
  111.       IF (IERR.NE.0) GOTO 666
  112. *
  113.       IPCH5O = IPCHE5
  114.       IF (IPCHE5.NE.0) THEN
  115.         CALL QUESUP(IPMODL,IPCH5O,ISUP1,0,ISUP5,iret5)
  116.         IF (ISUP5.GT.1) GOTO 666
  117.         IF (IERR.NE.0) GOTO 666
  118. C Le support des caractéristiques est différent de celui de IPCHE1
  119.         IF (ISUP5.NE.0) THEN
  120.           CALL CHASUP(IPMODL,IPCH5O,IPCHE5,irecar,ISUP1)
  121.           IF (irecar.NE.0) GOTO 666
  122.         ENDIF
  123.       ENDIF
  124. *
  125. *  Activation et verification du modele
  126. *
  127.       MMODEL = IPMODL
  128.       SEGACT,MMODEL
  129.       NSOUS = KMODEL(/1)
  130.       KEL22 = 0
  131.       DO ISOUS = 1, NSOUS
  132.         IMODEL=KMODEL(ISOUS)
  133.         SEGACT,IMODEL
  134.         IF (FORMOD(1).NE.'MECANIQUE' .AND.
  135.      &      FORMOD(1).NE.'POREUX') THEN
  136.           MOTERR(1:8) = FORMOD(1)
  137.           CALL ERREUR(193)
  138.           GOTO 666
  139.         ENDIF
  140.         IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22 + 1
  141.       ENDDO
  142. *
  143. C ... Initialisation des trois nouveaux MCHELM - resultats ...
  144.       N1 = NSOUS - KEL22
  145.       L1 = 8
  146.       N3 = 6
  147. *
  148.       SEGINI MCHEL1
  149.       MCHEL1.IFOCHE=IFOUR
  150.       MCHEL1.TITCHE='SCALAIRE'
  151. *
  152.       SEGINI MCHEL2
  153.       MCHEL2.IFOCHE=IFOUR
  154.       MCHEL2.TITCHE='SCALAIRE'
  155. *
  156.       SEGINI MCHEL3
  157.       MCHEL3.IFOCHE=IFOUR
  158.       MCHEL3.TITCHE='SCALAIRE'
  159. *
  160. * Petit segment utile
  161.       nbtype = 1
  162.       SEGINI,notype
  163.       type(1)='REAL*8'
  164.       MOTYPE = notype
  165. *
  166.       ISOUS = 0
  167. *
  168. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  169. *
  170.       DO 200 JSOUS = 1, NSOUS
  171. *
  172.         IMODEL = KMODEL(JSOUS)
  173.         SEGACT,IMODEL
  174. *
  175.         IPMAIL= IMAMOD
  176.         CONM  = CONMOD
  177.         MELE  = NEFMOD
  178. *
  179.         iOK = 1
  180.         IF ((MELE.EQ.22).OR.(MELE.EQ.259)) GOTO 210
  181. *
  182.         iOK = 0
  183. *
  184. C    ... COQUE INTEGREE OU NON ? ...
  185.         NPINT = INFMOD(1)
  186.         IF (NPINT.NE.0)THEN
  187.           CALL ERREUR(615)
  188.           GOTO 210
  189.         ENDIF
  190. *
  191. *    ... INITIALISATION ...
  192. *
  193.         ISOUS = ISOUS + 1
  194. *
  195.         IVACAR = 0
  196.         IVACOM = 0
  197.         MOCOMP = 0
  198.         MOCARA = 0
  199.         lsupno = .false.
  200. *
  201. *  ... INFORMATION SUR L'ELEMENT FINI ...
  202. *
  203.         MFR   = INFELE(13)
  204.         MINTE = INFMOD(2+ISUP1)
  205.         NSTRS = INFELE(16)
  206. *
  207. *  ... Verification de compatibilité des MCHAML du point de vue des
  208. *      tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  209. *
  210.         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE5,INFOS,IRTD)
  211.         IF (IRTD.EQ.0) GOTO 210
  212. *
  213. *  ... RECHERCHE DES NOMS de COMPOSANTES de CONTRAINTES/DEFORMATIONS...
  214. *
  215.         IF (ICONTR.EQ.1) THEN
  216.           IF (lnomid(4).NE.0) THEN
  217.             MOCOMP = lnomid(4)
  218.           ELSE
  219.             lsupno = .true.
  220.             CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  221.           ENDIF
  222.         ELSE
  223.           IF (lnomid(5).NE.0) THEN
  224.             MOCOMP = lnomid(5)
  225.           ELSE
  226.             lsupno = .true.
  227.             CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  228.           ENDIF
  229.         ENDIF
  230.         nomid = MOCOMP
  231.         SEGACT,nomid
  232.         NCOMP = lesobl(/2)
  233.         NFAC  = lesfac(/2)
  234. *
  235. *    ... VERIFICATION DE LEUR PRESENCE ...
  236. *
  237.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM)
  238.         IF (IERR.NE.0) GOTO 220
  239. *
  240. *    ... TRAITEMENT DES CHAMPS DE CARACTERISTIQUES ...
  241. *
  242.         nbrobl = 0
  243.         nbrfac = 0
  244.         nomid  = 0
  245. *    ... EPAISSEUR DANS LE CAS DES COQUES MINCES ...
  246.         IF (MFR.EQ.3 .OR. MFR.EQ.9) THEN
  247.           nbrobl = 1
  248.           nbrfac = 0
  249.           SEGINI,nomid
  250.           lesobl(1) = 'EPAI'
  251.         ENDIF
  252. *
  253.         MOCARA = nomid
  254.         NCARA = nbrobl
  255.         NCARF = nbrfac
  256.         NCARR = NCARA+NCARF
  257. *
  258.         IF (MOCARA.NE.0 .AND. NCARA.GE.1)  THEN
  259.           IF (IPCHE5.NE.0)  THEN
  260. C          ... On vérifie si elle est présente dans le champ de
  261. C              caractéristiques qui a été fourni ...
  262.             CALL KOMCHA(IPCHE5,IPMAIL,CONM,MOCARA,MOTYPE,1,
  263.      &                                     INFOS,3,IVACAR)
  264.           ELSE
  265. C          ... S'il n'y a pas de champ de caractéristiques, on râle ...
  266.             MOTERR(1:8)='CARACTER'
  267.             MOTERR(9:12)=NOMTP(MELE)
  268.             MOTERR(13:20)='INVA'
  269.             CALL ERREUR(145)
  270.           ENDIF
  271.           IF (IERR.NE.0) GOTO 230
  272.         ENDIF
  273. *
  274. C  Creation des MELVAL de la zone élémentaire
  275. *
  276. *  ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  277. *
  278.         MPTVAL = IVACOM
  279.         N1PTEL= 0
  280.         N1EL  = 0
  281.         DO 110 ICOMP = 1, NCOMP
  282.           MELVAL = IVAL(ICOMP)
  283.           N1PTEL = MAX(N1PTEL,VELCHE(/1))
  284.           N1EL   = MAX(N1EL  ,VELCHE(/2))
  285.  110    CONTINUE
  286.         N2PTEL=0
  287.         N2EL  =0
  288. *
  289.         SEGINI,MELVA1,MELVA2,MELVA3
  290. *
  291. *  Création des MCHAML ...
  292. *
  293.         N2 = 1
  294.         SEGINI,MCHAM1
  295.         SEGINI,MCHAM2
  296.         SEGINI,MCHAM3
  297. *
  298.         MCHAM1.NOMCHE(1)='SCAL'
  299.         MCHAM1.TYPCHE(1)='REAL*8'
  300.         MCHAM1.IELVAL(1)=MELVA1
  301. *
  302.         MCHAM2.NOMCHE(1)='SCAL'
  303.         MCHAM2.TYPCHE(1)='REAL*8'
  304.         MCHAM2.IELVAL(1)=MELVA2
  305. *
  306.         MCHAM3.NOMCHE(1)='SCAL'
  307.         MCHAM3.TYPCHE(1)='REAL*8'
  308.         MCHAM3.IELVAL(1)=MELVA3
  309. *
  310. * Remplissage des attributs de la sous-zone ...
  311. *
  312.         MCHEL1.INFCHE(ISOUS,1)=0
  313.         MCHEL1.INFCHE(ISOUS,2)=0
  314.         MCHEL1.INFCHE(ISOUS,3)=NIFOUR
  315.         MCHEL1.INFCHE(ISOUS,4)=MINTE
  316.         MCHEL1.INFCHE(ISOUS,5)=0
  317.         MCHEL1.INFCHE(ISOUS,6)=ISUP1
  318.         MCHEL1.IMACHE(ISOUS)=IPMAIL
  319.         MCHEL1.CONCHE(ISOUS)=CONMOD
  320.         MCHEL1.ICHAML(ISOUS)=MCHAM1
  321. *
  322.         MCHEL2.INFCHE(ISOUS,1)=0
  323.         MCHEL2.INFCHE(ISOUS,2)=0
  324.         MCHEL2.INFCHE(ISOUS,3)=NIFOUR
  325.         MCHEL2.INFCHE(ISOUS,4)=MINTE
  326.         MCHEL2.INFCHE(ISOUS,5)=0
  327.         MCHEL2.INFCHE(ISOUS,6)=ISUP1
  328.         MCHEL2.IMACHE(ISOUS)=IPMAIL
  329.         MCHEL2.CONCHE(ISOUS)=CONMOD
  330.         MCHEL2.ICHAML(ISOUS)=MCHAM2
  331. *
  332.         MCHEL3.INFCHE(ISOUS,1)=0
  333.         MCHEL3.INFCHE(ISOUS,2)=0
  334.         MCHEL3.INFCHE(ISOUS,3)=NIFOUR
  335.         MCHEL3.INFCHE(ISOUS,4)=MINTE
  336.         MCHEL3.INFCHE(ISOUS,5)=0
  337.         MCHEL3.INFCHE(ISOUS,6)=ISUP1
  338.         MCHEL3.IMACHE(ISOUS)=IPMAIL
  339.         MCHEL3.CONCHE(ISOUS)=CONMOD
  340.         MCHEL3.ICHAML(ISOUS)=MCHAM3
  341. *
  342. **********************************************************************
  343. *                                                                    *
  344. *               BRANCHEMENT SUIVANT LA FORMULATION                   *
  345. *                                                                    *
  346. **********************************************************************
  347. *            MASSI   COQUE    COQEP          CIST
  348.         GOTO ( 30, 99, 60, 99, 80, 99, 99, 99,120, 99,
  349.      &         99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
  350.      &         99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
  351. *             INCO    PORE
  352.      &         30, 99, 30, 99, 99, 99, 99, 99, 99, 99), MFR
  353. C == FORMULATION HHO == IDENTIQUE au CAS MASSIF ========================
  354.         IF (MFR.EQ.HHO_MFR_ELEMENT) GOTO 30
  355. C == FORMULATION HHO ===================================================
  356. C       XFEM : idem massif
  357.         IF (MFR.EQ.63) GOTO 30
  358. C
  359.  99     CONTINUE
  360.         MOTERR(1:8) = NOMFR(MFR/2+1)
  361.         CALL ERREUR(193)
  362.         GOTO 240
  363. *_______________________________________________________________________
  364. *
  365. *    FORMULATION MASSIVE / INCOMPRESSIBLE / POREUX / XFEM
  366. *_______________________________________________________________________
  367. *
  368.    30   CONTINUE
  369.         DO IB=1,N1EL
  370.           DO IGAU=1,N1PTEL
  371. *
  372. C       ... Recherche des composantes du champ des contraintes ...
  373.             MPTVAL=IVACOM
  374.             DO ICOMP=1,NCOMP
  375.                MELVAL=IVAL(ICOMP)
  376.                IGMN=MIN(IGAU,VELCHE(/1))
  377.                IBMN=MIN(IB  ,VELCHE(/2))
  378.                SIG(ICOMP)=VELCHE(IGMN,IBMN)
  379.             ENDDO
  380.  
  381. C       ... Calcul des invariants ...
  382.  
  383.             XI1=SIG(1)+SIG(2)+SIG(3)
  384.             IF (IFOUR.LT.1.AND.IFOUR.GT.-3) THEN
  385.                XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  386.      .             W1*SIG(4)*SIG(4)
  387.                XI3=SIG(3)*(SIG(1)*SIG(2)-W2*SIG(4)*SIG(4))
  388.             ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  389.                XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)
  390.                XI3=SIG(1)*SIG(2)*SIG(3)
  391.             ELSE
  392.                XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  393.      .             W1*(SIG(4)*SIG(4)+SIG(5)*SIG(5)+SIG(6)*SIG(6))
  394.                XI3=SIG(1)*SIG(2)*SIG(3)-
  395.      .             W2*(SIG(1)*SIG(6)*SIG(6)+SIG(2)*SIG(5)*SIG(5)+
  396.      .             SIG(3)*SIG(4)*SIG(4))+W3*SIG(4)*SIG(5)*SIG(6)
  397.             ENDIF
  398.  
  399. C       ... et leur stockage ...
  400.  
  401.             MELVA1.VELCHE(IGAU,IB)=XI1
  402.             MELVA2.VELCHE(IGAU,IB)=XI2
  403.             MELVA3.VELCHE(IGAU,IB)=XI3
  404.  
  405.           ENDDO
  406.         ENDDO
  407.         GOTO 250
  408. *_______________________________________________________________________
  409. *
  410. *    FORMULATION COQUE MINCE
  411. *_______________________________________________________________________
  412. *
  413.    60 CONTINUE
  414.       DO IB=1,N1EL
  415.         DO IGAU=1,N1PTEL
  416. C       ... Recherche des composantes du champ des contraintes généralisées ...
  417.             MPTVAL=IVACOM
  418.             DO ICOMP=1,NCOMP
  419.                MELVAL=IVAL(ICOMP)
  420.                IGMN=MIN(IGAU,VELCHE(/1))
  421.                IBMN=MIN(IB  ,VELCHE(/2))
  422.                SIG(ICOMP)=VELCHE(IGMN,IBMN)
  423.             ENDDO
  424. *
  425. C       ... Recherche de l'épaisseur de la coque ...
  426.             MPTVAL=IVACAR
  427.             MELVAL=IVAL(1)
  428.             IGMN=MIN(IGAU,VELCHE(/1))
  429.             IBMN=MIN(IB  ,VELCHE(/2))
  430.             EPAIST=VELCHE(IGMN,IBMN)
  431. *
  432. *       ... CALCUL DES CONTRAINTES ...
  433. *
  434.             CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  435.             IF(IFOUR.GT.0) THEN
  436.                SIG(1)=SIG(1)+SIG(4)*IMIL
  437.                SIG(2)=SIG(2)+SIG(5)*IMIL
  438.                SIG(3)=SIG(3)+SIG(6)*IMIL
  439.             ELSE IF(IFOUR.LE.0) THEN
  440.                SIG(1)=SIG(1)+SIG(3)*IMIL
  441.                SIG(2)=SIG(2)+SIG(4)*IMIL
  442.                SIG(3)=0.D0
  443.             ENDIF
  444. *
  445. C       ... Calcul des invariants ...
  446.  
  447.             XI1=SIG(1)+SIG(2)
  448.             XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+W1*SIG(3)*SIG(3)
  449.             XI3=0.D0
  450. *
  451. C       ... et leur stockage ...
  452.             MELVA1.VELCHE(IGAU,IB)=XI1
  453.             MELVA2.VELCHE(IGAU,IB)=XI2
  454.             MELVA3.VELCHE(IGAU,IB)=XI3
  455. *
  456.           ENDDO
  457.         ENDDO
  458.         GOTO 250
  459. *_______________________________________________________________________
  460. *
  461. *    FORMULATION COQUE EPAISSE
  462. *_______________________________________________________________________
  463. *
  464.    80   CONTINUE
  465.         DO IB=1,N1EL
  466.           DO IGAU=1,N1PTEL
  467. C       ... Recherche des composantes du champ des contraintes ...
  468.             MPTVAL=IVACOM
  469.             DO ICOMP=1,NCOMP
  470.                MELVAL=IVAL(ICOMP)
  471.                IGMN=MIN(IGAU,VELCHE(/1))
  472.                IBMN=MIN(IB  ,VELCHE(/2))
  473.                SIG(ICOMP)=VELCHE(IGMN,IBMN)
  474.             ENDDO
  475. *
  476. C       ... Calcul des invariants ...
  477.  
  478.             XI1=SIG(1)+SIG(2)
  479.             XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+
  480.      &          W1*(SIG(3)*SIG(3)+SIG(4)*SIG(4)+SIG(5)*SIG(5))
  481.             XI3=-W2*(SIG(1)*SIG(5)*SIG(5)+SIG(2)*SIG(4)*SIG(4))
  482.      &          +W3*SIG(3)*SIG(4)*SIG(5)
  483. *
  484. C       ... et leur stockage ...
  485.  
  486.             MELVA1.VELCHE(IGAU,IB)=XI1
  487.             MELVA2.VELCHE(IGAU,IB)=XI2
  488.             MELVA3.VELCHE(IGAU,IB)=XI3
  489. *
  490.           ENDDO
  491.         ENDDO
  492.         GOTO 250
  493. *_______________________________________________________________________
  494. *
  495. *    FORMULATION COQUE AVEC CISAILLEMENT
  496. *_______________________________________________________________________
  497. *
  498.   120   CONTINUE
  499.         DO IB=1,N1EL
  500.           DO IGAU=1,N1PTEL
  501. C       ... Recherche des composantes du champ des contraintes ...
  502.             MPTVAL=IVACOM
  503.             DO ICOMP=1,NCOMP
  504.                MELVAL=IVAL(ICOMP)
  505.                IGMN=MIN(IGAU,VELCHE(/1))
  506.                IBMN=MIN(IB  ,VELCHE(/2))
  507.                SIG(ICOMP)=VELCHE(IGMN,IBMN)
  508.             ENDDO
  509. *
  510. C       ... Recherche de l'épaisseur de la coque ...
  511.             MPTVAL=IVACAR
  512.             MELVAL=IVAL(1)
  513.             IGMN=MIN(IGAU,VELCHE(/1))
  514.             IBMN=MIN(IB  ,VELCHE(/2))
  515.             EPAIST=VELCHE(IGMN,IBMN)
  516. *
  517. *       ... CALCUL DES CONTRAINTES ...
  518. *
  519.             CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  520.             SIG(1)=SIG(1)+SIG(4)*IMIL
  521.             SIG(2)=SIG(2)+SIG(5)*IMIL
  522.             SIG(4)=SIG(3)+SIG(6)*IMIL
  523.             SIG(3)=0.D0
  524.             SIG(5)=SIG(7)
  525.             SIG(6)=SIG(8)
  526.  
  527. C       ... Calcul des invariants ...
  528.  
  529.             XI1=SIG(1)+SIG(2)+SIG(3)
  530.             XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  531.      &          W1*(SIG(4)*SIG(4)+SIG(5)*SIG(5)+SIG(6)*SIG(6))
  532.             XI3=SIG(1)*SIG(2)*SIG(3)-
  533.      &          W2*(SIG(1)*SIG(6)*SIG(6)+SIG(2)*SIG(5)*SIG(5)+
  534.      &          SIG(3)*SIG(4)*SIG(4))+W3*SIG(4)*SIG(5)*SIG(6)
  535. *
  536. C       ... et leur stockage ...
  537.             MELVA1.VELCHE(IGAU,IB)=XI1
  538.             MELVA2.VELCHE(IGAU,IB)=XI2
  539.             MELVA3.VELCHE(IGAU,IB)=XI3
  540. *
  541.           ENDDO
  542.         ENDDO
  543.         GOTO 250
  544. *
  545. **********************************************************************
  546. *                                                                    *
  547. *           FIN DU BRANCHEMENT SUIVANT LA FORMULATION                *
  548. *                                                                    *
  549. **********************************************************************
  550. *
  551. *    ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  552. *
  553.   250    CONTINUE
  554.          iOK = 1
  555.  
  556.   240    CONTINUE
  557.          SEGDES,MELVA1,MELVA2,MELVA3
  558.          SEGDES,MCHAM1,MCHAM2,MCHAM3
  559. *
  560.  230    CONTINUE
  561.         IF (MOCARA.NE.0) THEN
  562.           nomid = MOCARA
  563.           SEGSUP,nomid
  564.         ENDIF
  565. *
  566.         CALL DTMVAL(IVACOM,1)
  567. *
  568.  220    CONTINUE
  569.         nomid = MOCOMP
  570.         SEGDES,nomid
  571.         IF (lsupno) SEGSUP,nomid
  572. *
  573.  210    CONTINUE
  574.         SEGDES,IMODEL
  575. *
  576. * ... ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR ...
  577.         IF (iOK.EQ.0) GOTO 990
  578. *
  579.   200 CONTINUE
  580.  
  581. C ... FIN DE LA GRANDE BOUCLE SUR LES ZONES ÉLÉMENTAIRES ...
  582.  
  583.       IRET = 1
  584.  
  585.  990  CONTINUE
  586.       SEGDES,MMODEL
  587.  
  588.       IF (IRET.EQ.1) THEN
  589.         SEGDES,MCHEL1,MCHEL2,MCHEL3
  590.         IPCHE2 = MCHEL1
  591.         IPCHE3 = MCHEL2
  592.         IPCHE4 = MCHEL3
  593.       ELSE
  594.         SEGSUP,MCHEL1,MCHEL2,MCHEL3
  595.         IPCHE2 = 0
  596.         IPCHE3 = 0
  597.         IPCHE4 = 0
  598.       ENDIF
  599. *
  600.       SEGSUP,notype
  601.       IF (IPCH5O.NE.IPCHE5) THEN
  602.         CALL DTCHAM(IPCHE5)
  603.         IPCHE5 = IPCH5O
  604.       ENDIF
  605. *
  606.   666 CONTINUE
  607.       SEGDES,MCHELM
  608.  
  609.       RETURN
  610.       END
  611.  
  612.  
  613.  
  614.  

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