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

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