Télécharger la plaquette Cast3M


fr en

Télécharger intgca.eso

Retour à la liste

Numérotation des lignes : 

intgca

  1. C INTGCA    SOURCE    PV090527  25/04/01    21:15:03     12222          
  2.  
  3. C=======================================================================
  4. C=                            I N T G C A                              =
  5. C=                            -----------                              =
  6. C=                                                                     =
  7. C=  Fonction :                                                         =
  8. C=  ----------                                                         =
  9. C=   Integration d'un champ scalaire sur un maillage ou par element.   =
  10. C=   Sous-programme appele par INTGRA (intgra.eso).                    =
  11. C=                                                                     =
  12. C=  Parametres :  (E)=Entree   (S)=Sortie                              =
  13. C=  ------------                                                       =
  14. C=   IPMODL   (E)   Pointeur sur le segment MMODEL                     =
  15. C=   IPCHE1   (E)   Pointeur sur segment MCHELM a une seule composante =
  16. C=   IPCHE2   (E)   Pointeur sur segment MCHELM de CARACTERISTIQUES    =
  17. C=   KOPELE   (E)   =0 si on ne veut pas un MCHAML resultat            =
  18. C=   IPINT    (S)   Pointeur sur le segment MCHELM resultat            =
  19. C=   XRET     (S)   Flottant resultant de l'integration si demande     =
  20. C=   IRET     (S)   Entier valant 1 en cas de succes, 0 sinon (et un   =
  21. C=                  message d'erreur est imprime dans ce cas)          =
  22. C=                                                                     =
  23. C=  Remarque : Autrefois, le champ resultat avait le meme support que  =
  24. C=  ---------- le champ IPCHE1,soit IPINT/MCHEL1.INFCHE(iSou,6)).      =
  25. C=             Maintenant, le champ resultat IPINT est donne au centre =
  26. C=             de gravite quelque soit le support du champ integre,    =
  27. C=             soit IPINT.INFCHE(iSou,6)=2 .                           =
  28. C=======================================================================
  29.  
  30.       SUBROUTINE INTGCA (IPMODL,IPCHE1,IPCHE2,KOPELE,IRET,XRET,IPINT)
  31.  
  32.       IMPLICIT INTEGER(I-N)
  33.       IMPLICIT REAL*8 (A-H,O-Z)
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC CCREEL
  38. -INC CCHAMP
  39. C==DEB= FORMULATION HHO == Include specifique ==========================
  40. -INC CCHHOPA
  41. C==FIN= FORMULATION HHO ================================================
  42.  
  43. -INC SMMODEL
  44. -INC SMCHAML
  45. -INC SMELEME
  46. -INC SMCOORD
  47. -INC SMINTE
  48.  
  49. -INC TMPTVAL
  50.  
  51.       SEGMENT MWRK1
  52.         REAL*8 SHP(6,NBNO),XEL(3,NBBB),BPSS(3,3),XE(3,NBBB)
  53.       ENDSEGMENT
  54.  
  55.       SEGMENT MWRK2
  56.         REAL*8 TXR(3,3,NBBB),XJ(3,3)
  57.       ENDSEGMENT
  58.  
  59.       SEGMENT MWRK3
  60.         REAL*8 WORK(LW)
  61.       ENDSEGMENT
  62.  
  63.       SEGMENT INFO
  64.         INTEGER INFELL(JG)
  65.       ENDSEGMENT
  66.  
  67.       SEGMENT NOTYPE
  68.         CHARACTER*16 TYPE(NBTYPE)
  69.       ENDSEGMENT
  70.  
  71.       PARAMETER (NINF=3)
  72.       INTEGER INFOS(NINF)
  73.       CHARACTER*(NCONCH) CONM
  74.       CHARACTER*8 CHARIN
  75.       LOGICAL LOGCOQ
  76.  
  77. C= Quelques constantes (2.Pi et 4.Pi)
  78.       PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  79.       PARAMETER (X4Pi=12.566370614359172953850573533118D0)
  80.  
  81. C ==============================
  82. C = Valeurs par defaut de sortie
  83. C ==============================
  84.       IRET  = 0
  85.       XRET  = REAL(0.D0)
  86.       IPINT = 0
  87.  
  88. C  1 - QUELQUES INITIALISATIONS
  89. C ==============================
  90. C  1.1 - Activation du MMODEL
  91. C =====
  92.       MMODEL = IPMODL
  93.       NSOUS  = mmodel.KMODEL(/1)
  94.  
  95. C =====
  96. C     Cas du MMODEL VIDE...
  97. C =====
  98.       IF (NSOUS .EQ. 0) THEN
  99.         IRET = 1
  100.         IF (KOPELE .NE. 0) THEN
  101.           L1=8
  102.           N1=0
  103.           N3=6
  104.           SEGINI,MCHELM
  105.           TITCHE='SCALAIRE'
  106.           IFOCHE=IFOUR
  107.           IPINT =MCHELM
  108.         ENDIF
  109.         RETURN
  110.       ENDIF
  111.  
  112. C  1.2 - Activation du MCHEL1
  113. C =====
  114.       MCHEL1 = IPCHE1
  115.       NZ = MCHEL1.ICHAML(/1)
  116.  
  117. C =====
  118. C  Cas particulier du champ IPCHE1 vide
  119. C =====
  120.       IF (NZ .EQ. 0) THEN
  121.         IRET = 1
  122.         IF (KOPELE .NE. 0) THEN
  123.           L1=8
  124.           N1=0
  125.           N3=6
  126.           SEGINI,MCHELM
  127.           TITCHE='SCALAIRE'
  128.           IFOCHE=IFOUR
  129.           IPINT =MCHELM
  130.         ENDIF
  131.         RETURN
  132.       ENDIF
  133.  
  134.  
  135. C  2 - VERIFICATIONS DES DONNEES DE L'OPERATEUR
  136. C      Verification du lieu support du MCHAML a integrer
  137. C =======================================================
  138.       IMODEL=KMODEL(1)
  139.       NFOR  =FORMOD(/2)
  140.       CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE')
  141.       CALL PLACE(FORMOD,NFOR,IDIFF,'DIFFUSION')
  142.       CALL PLACE(FORMOD,NFOR,IMETA,'METALLURGIE')
  143.  
  144.       IF(ITHER.NE.0 .OR. IDIFF.NE.0 .OR. IMETA.NE.0)THEN
  145.         nmat = matmod(/2)
  146.         CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  147. C       Support 6 SAUF pour le RAYONNEMENT...
  148. C       Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  149.         IF (iray.EQ.0) THEN
  150.           IS = 6
  151.         ELSE
  152.           IS = 3
  153.         ENDIF
  154.  
  155.       ELSE
  156. *       On determine le support du champ d'entree
  157.         IS   =0
  158.         ISup1=0
  159.         iOK  =0
  160.         CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK)
  161.         IF (iOK.EQ.9999) call erreur(609)
  162.         if (ierr.ne.0) return
  163.         IS=iOK
  164. *       Dans le cas d'un champ constant, au centre de gravite ou aux noeuds,
  165. *       on utilise les points de la rigidite.
  166.         IF (IS.EQ.1 .OR. IS.EQ.2) IS=3
  167.       ENDIF
  168.  
  169.       ISup1=0
  170.       iOK  =0
  171.       CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK)
  172.       IF (ISup1.GT.1) call erreur(609)
  173.       if (ierr.ne.0) return
  174.  
  175. C =====
  176. C  2.2 - Initialisation du MCHELM resultat si demande
  177. C =====
  178.       IF (KOPELE .NE. 0) THEN
  179.         L1=8
  180.         N1=NSOUS
  181.         N3=6
  182.         SEGINI,MCHELM
  183.         TITCHE='SCALAIRE'
  184.         IFOCHE=IFOUR
  185.         IPINT =MCHELM
  186.       ENDIF
  187.  
  188. C =====
  189. C  2.3 - Recuperation du nom de la composante de IPCHE1
  190. C        Traitement effectue ici car identique sur tout le modele
  191. C =====
  192.       MCHAML = MCHEL1.ICHAML(1)
  193.       NBROBL=1
  194.       NBRFAC=0
  195.       SEGINI,NOMID
  196.       LESOBL(1)=mchaml.NOMCHE(1)
  197.       MOCOMP=NOMID
  198.  
  199.       NBTYPE=1
  200.       SEGINI,NOTYPE
  201.       TYPE(1)='REAL*8'
  202.       MOTYCO=NOTYPE
  203.  
  204. C  3 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou)
  205. C ========================================================
  206.       isouss=0
  207.       DO 2000 iSou=1,NSOUS
  208. C =====
  209. C  3.1 - Quelques initialisations
  210. C =====
  211.         IVACOM=0
  212.         NCARR =0
  213.         IVACAR=0
  214.         MCHAML=0
  215.         IPMEL1=0
  216.         IPMEL2=0
  217.         MWRK3 =0
  218.  
  219. C =====
  220. C  3.2 - Activation du sous-modele (iSou)
  221. C =====
  222.         IMODEL = KMODEL(iSou)
  223.         MELE   = NEFMOD
  224.         if( (mele.eq.22).or.(mele.eq.259)) goto 2000
  225.  
  226.         isouss=isouss+1
  227.         CONM   = CONMOD
  228.  
  229. C =====
  230. C  3.3 - Recuperation du maillage associe au sous-modele (iSou)
  231. C        Traitement particulier dans le cas d'une formulation DARCY
  232. C =====
  233.         IPMAIL=IMAMOD
  234.         CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
  235.         IF (IDARC.NE.0) THEN
  236.           CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  237.           CHARIN='MAILLAGE'
  238.           CALL LEKTAB(IPTABL,CHARIN,IOBRE)
  239.           IF (IERR.NE.0) GOTO 240
  240.  
  241.           IF (NSOUS.GT.1)THEN
  242.             IPT1=IOBRE
  243.             CALL ACTOBJ('MAILLAGE',IPT1,1)
  244.             IPMAIL=IPT1.LISOUS(iSou)
  245.           ELSE
  246.             IPMAIL=IOBRE
  247.           ENDIF
  248.         ENDIF
  249.  
  250. C =====
  251. C  3.4 - Determination ...
  252. C =====
  253.         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,iOK)
  254.         IF (iOK.EQ.0) GOTO 240
  255.         iOK=0
  256.  
  257. C =====
  258. C  3.5 - Recuperation d'informations sur l'element fini du sous-modele
  259. C        ERREUR si la formulation n'est pas disponible
  260. C   ???? ERREUR si l'element est une element JOINT (non implante)
  261. C =====
  262.         LOGCOQ=.FALSE.
  263.         IF (ITHER.EQ.0 .AND. IDIFF.EQ.0) THEN
  264.           if (infmod(/1).lt.4) then
  265.             CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  266.             IF (IERR.NE.0) GOTO 240
  267.             INFO=IPINF
  268.             mincdg=INFELL(11)
  269.             SEGSUP,INFO
  270.           else
  271.             mincdg=infmod(4)
  272.           endif
  273. C*        if(infmod(/1).lt.5) then
  274. C*         CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  275.           if(infmod(/1).lt.IS+2) then
  276.            CALL ELQUOI(MELE,0,IS,IPINF,IMODEL)
  277.            IF (IERR.NE.0) GOTO 240
  278.            INFO=IPINF
  279.            NBPGAU=INFELL(4)
  280.            IPMINT=INFELL(11)
  281.            MINTE1=INFELL(12)
  282.            MFR=INFELL(13)
  283.            LW=INFELL(7)
  284.            NLG=INFELL(14)
  285.            SEGSUP,INFO
  286.           else
  287. C*          IPMINT=infmod(5)
  288.             NBPGAU=INFELE(4)
  289.             IPMINT=infmod(IS+2)
  290.             MINTE1=0
  291.             if (infmod(/1).ge.8) MINTE1=INFMOD(8)
  292.             MFR=INFELE(13)
  293.             LW=INFELE(7)
  294.             IPORE=INFELE(8)
  295.             NLG=INFELE(14)
  296.           endif
  297.           if (NUMMFR(MELE).eq.27) MFR = NUMMFR(MELE)
  298.           IF (MFR.EQ.5) LOGCOQ=.TRUE.
  299.           MINTE=IPMINT
  300.         ELSE
  301.           mincdg=0
  302.           LW=100
  303.           CALL TSHAPE(MELE,'GAUSS',IPMINT)
  304.           MINTE=IPMINT
  305.           IF (MELE.EQ.41.OR.MELE.EQ.56.OR.MELE.EQ.49) THEN
  306.             LOGCOQ=.TRUE.
  307.             CALL TSHAPE(MELE,'NOEUD',IPMIN1)
  308.             MINTE1=IPMIN1
  309.           ENDIF
  310.           NBPGAU=minte.poigau(/1)
  311.           MFR=NUMMFR(MELE)
  312.           NLG=NUMGEO(MELE)
  313.         ENDIF
  314.         IF (MFR.NE. 1.AND.MFR.NE. 3.AND.MFR.NE. 7.AND.MFR.NE.9.AND.
  315.      .      MFR.NE.11.AND.MFR.NE.13.AND.MFR.NE.33.AND.MFR.NE.5.AND.
  316.      .      MFR.NE.26.AND.MFR.NE.28.and.MFR.NE.78.and.MFR.NE.15.AND.
  317.      .      MFR.NE.17.AND.MFR.NE.49                            .AND.
  318.      .      MFR.NE.31.AND.MFR.NE.35.AND.MFR.NE.63.AND.MFR.NE.71.AND.
  319.      &      MFR.NE.73.AND.MFR.NE.57.AND.MFR.NE.59.AND.MFR.NE.77.AND.
  320. C==DEB= FORMULATION HHO ================================================
  321.      &      MFR.NE.HHO_MFR_ELEMENT .AND.
  322. C==FIN= FORMULATION HHO ================================================
  323.      &      MFR.NE.72.AND.MFR.NE.74.AND.MFR.NE.27.AND.MFR.NE.75) THEN
  324.           MOTERR=NOMTP(MELE)
  325.           CALL ERREUR(193)
  326.           GOTO 240
  327.         ENDIF
  328.         IF (MFR.EQ.35.AND.IDIM.NE.2) THEN
  329.           IF (MELE.NE.87.AND.MELE.NE.88) THEN
  330.             MOTERR(1:4)=NOMTP(MELE)
  331.             MOTERR(5:12)='INTG'
  332.             CALL ERREUR(86)
  333.             GOTO 240
  334.           ENDIF
  335.         ENDIF
  336.         CALL QUEDIM(NLG,JDIM)
  337.  
  338. C =====
  339. C  3.6 - Recuperation de la composante a integrer
  340. C        Verification de sa presence dans le MCHAML (IPCHE1)
  341. C        Appel a KOMCHA : NINFO=0 pour le moment...
  342. C        Recuperation du MELVAL associe a ce MCHAML sur IPMAIL
  343. C =====
  344.         NINFO=0
  345.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYCO,1,
  346.      .              INFOS,NINFO,IVACOM)
  347.         IF (IERR.NE.0) GOTO 230
  348.         MPTVAL=IVACOM
  349.         MELVA1=IVAL(1)
  350.         NBPTEL=MELVA1.VELCHE(/1)
  351.         IF (ISup1.EQ.1 .AND. IPMINT .NE. 0) THEN
  352.           IPMELE=MELVA1
  353.           CALL VALMEL(IPMELE,IPMINT,IPMELS)
  354.           MELVA1=IPMELS
  355.         ENDIF
  356.         IPMEL1=MELVA1
  357.  
  358. C =====
  359. C  3.7 - Recuperation des noms des caracteristiques geometriques
  360. C =====
  361.         MOCARA = 0
  362.         IF (IPCHE2.NE.0) THEN
  363.           CHARIN='        '
  364.           CALL CARAMK(MFR,IFOUR,MELE,CHARIN,MOCARA,NCARA,NCARF,NCARR,
  365.      &                MOTYPE,NBTYPE)
  366.           IF (NCARR.NE.0) THEN
  367.             CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  368.      &                  IVACAR)
  369.           ENDIF
  370.           NOMID = MOCARA
  371.           SEGSUP,NOMID
  372.           NOTYPE = MOTYPE
  373.           SEGSUP,NOTYPE
  374.           IF (IERR.NE.0) GOTO 210
  375.         ENDIF
  376. c        IF (IVACAR.NE.0) THEN
  377. c          MPTVAL=IVACAR
  378. c          DO i=1,IVAL(/1)
  379. c            IPMELV=IVAL(i)
  380. c            CALL QUELCH(IPMELV,ICONS)
  381. c            IF (ICONS.NE.0) THEN
  382. c              CALL ERREUR(566)
  383. c              GOTO 210
  384. c            ENDIF
  385. c          ENDDO
  386. c        ENDIF
  387.  
  388. C =====
  389. C  3.8 - Activation du maillage elementaire MELEME
  390. C =====
  391.         MELEME=IPMAIL
  392.         NBNN  =NUM(/1)
  393.         NBELEM=NUM(/2)
  394.  
  395. C =====
  396. C  3.9 - Initialisation du MCHAML resultat (MCHAML) associe au modele
  397. C        elementaire iSou (de maillage IPMAIL) SI demande
  398. C        Remplissage des donnees associees a MCHAML dans MCHELM (global)
  399. C =====
  400.         IF (KOPELE.NE.0) THEN
  401. C= 3.9.1 - Initialisation de MCHAML
  402.           N2=1
  403.           SEGINI,MCHAML
  404.           NOMCHE(N2)='SCAL'
  405.           TYPCHE(N2)='REAL*8'
  406. C= 3.9.2 - Remplissage de MCHEML(iSou)
  407.           CONCHE(iSouss)   = CONM
  408.           IMACHE(iSouss)   = IPMAIL
  409.           ICHAML(iSouss)   = MCHAML
  410.           INFCHE(iSouss,1) = 0
  411.           INFCHE(iSouss,2) = 0
  412.           INFCHE(iSouss,3) = NIFOUR
  413.           INFCHE(iSouss,4) = MCHEL1.INFCHE(iSouss,4)
  414.           IF (mincdg.NE.0) INFCHE(iSouss,4) = mincdg
  415.           INFCHE(iSouss,5) = 0
  416. C         En attendant une unification et un support GRAVITE pour la THERMIQUE / DIFFUSION / METALLURGIE
  417.           IF(ITHER.NE.0 .OR. IDIFF.NE.0 .OR. IMETA.NE.0)THEN
  418.             INFCHE(iSouss,6)=1
  419.           ELSE
  420.             INFCHE(iSouss,6)=2
  421.           ENDIF
  422. C= 3.9.3 - Initialisation du MELVAL associe a ce MCHAML
  423.           N1PTEL     = 1
  424.           N1EL       = NBELEM
  425.           N2PTEL     = 0
  426.           N2EL       = 0
  427.           SEGINI,MELVA2
  428.           IELVAL(N2) = MELVA2
  429.           IPMEL2     = MELVA2
  430.         ENDIF
  431.  
  432. C ======
  433. C  3.10 - Recuperation des donnees d'integration
  434. C         Traitement particulier dans le cas du COQ4 (si le nombre de
  435. C         points de Gauss vaut 5, seuls les 4 premiers sont traites, le
  436. C         5e servant uniquement au cisaillement)
  437. C ======
  438.         IF(MFR .NE. 75)THEN
  439.           NBPGAU=POIGAU(/1)
  440.         ELSE
  441. C         Cas des JOI1 en attendant un TJOI1.ESO dans tshape.eso
  442.           NBPGAU=NBNN
  443.         ENDIF
  444.         NBBB  =NBNN
  445.         NBNO  =NBNN
  446.         IF ((MELE.GE.108.AND.MELE.LE.110).OR.
  447.      &      (MELE.GE.185.AND.MELE.LE.190)) NBNO=IPORE
  448.         IF (MELE.EQ.49) THEN
  449.           IF (NBPGAU.EQ.5) NBPGAU=4
  450.           IF (NBPTEL.EQ.5) NBPTEL=4
  451.         ENDIF
  452.  
  453. C ======
  454. C  3.11 - Initialisation de quelques segments de travail
  455. C ======
  456.         SEGINI,MWRK1
  457.         IF (LOGCOQ) THEN
  458.           SEGINI,MWRK2
  459.           SEGACT,MINTE1
  460.           SEGINI,MWRK3
  461.         ELSE IF (IPCHE2.NE.0) THEN
  462.           SEGINI,MWRK3
  463.         ENDIF
  464.  
  465. C ======
  466. C  3.12 - Boucle sur les elements du sous-modele elementaire
  467. C ======
  468.  
  469. C==DEB= FORMULATION HHO ================================================
  470.         IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  471.           IF (MELE.NE.HHO_NUM_ELEMENT) THEN
  472.             CALL ERREUR(5)
  473.           END IF
  474.           VALHHO = REAL(0.D0)
  475.           CALL HHOITG(IMODEL, IPMEL1,
  476.      &                        IVACAR,NCARR, IPMINT,NBPGAU,
  477.      &                        VALHHO, IPMEL2, iret)
  478.           IF (iret.NE.0) THEN
  479.             CALL ERREUR(iret)
  480.             GOTO 200
  481.           END IF
  482.           XRET = XRET + VALHHO
  483.           iOK = 1
  484.           GOTO 200
  485.         END IF
  486. C==FIN= FORMULATION HHO ================================================
  487.  
  488.         DO IB=1,NBELEM
  489. C= 3.12.1 - Recuperation des coordonnees des noeuds de l element IB
  490.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  491.  
  492. C= 3.12.2 - Determination des axes locaux aux noeuds (elements COQUES)
  493.           IF (LOGCOQ) THEN
  494.             CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  495.             IF (IRR.EQ.0) THEN
  496.               CALL ERREUR(515)
  497.               GOTO 200
  498.             ENDIF
  499.             IF (IVACAR.NE.0) THEN
  500.               MPTVAL=IVACAR
  501.               DO iGau=1,NBPGAU
  502.                 MELVAL=IVAL(1)
  503.                 IGMN=MIN(iGau,VELCHE(/1))
  504.                 IBMN=MIN(IB,VELCHE(/2))
  505.                 WORK(iGau)=VELCHE(IGMN,IBMN)
  506.                 IF (IVAL(2).NE.0) THEN
  507.                   MELVAL=IVAL(2)
  508.                   IGMN=MIN(iGau,VELCHE(/1))
  509.                   IBMN=MIN(IB,VELCHE(/2))
  510.                   WORK(20+iGau)=VELCHE(IGMN,IBMN)
  511.                 ELSE
  512.                   WORK(20+iGau)=0.D0
  513.                 ENDIF
  514.               ENDDO
  515.  
  516.             ELSE
  517. C*            Si pas de caracteristiques, on met les epaisseurs a 1 (et non a 0)
  518.               DO iGau=1,NBPGAU
  519.                 WORK(iGau)=1.D0
  520.               ENDDO
  521.             ENDIF
  522.           ENDIF
  523.  
  524. C= 3.12.3 - Boucle sur les points d'integration
  525.           ESTEL=XZero
  526.           DO iGau=1,NBPGAU
  527.             IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  528.             IGMN=MIN(iGau,MELVA1.VELCHE(/1))
  529.             FACSCA=MELVA1.VELCHE(IGMN,IBMN)
  530.  
  531. C= 3.12.3.1 - Elements COQUES
  532.             IF (LOGCOQ) THEN
  533.               E3=DZEGAU(iGau)
  534.               CALL CQ8JCE(iGau,NBNN,E3,XEL,WORK(1),WORK(21),
  535.      .                    TXR,SHPTOT,XJ,DJAC,IRR)
  536.               IF (IRR.LT.0) THEN
  537.                 INTERR(1)=IB
  538.                 CALL ERREUR(405)
  539.                 GOTO 200
  540.               ENDIF
  541.               DJAC=ABS(DJAC)*POIGAU(iGau)
  542.               ESTEL=ESTEL+FACSCA*DJAC
  543.  
  544. C= 3.12.3.2 - Elements JOINTS 2D
  545.             ELSE IF (MFR.EQ.35.AND.IDIM.EQ.2) THEN
  546.               DO i=1,NBNO
  547.                 SHP(1,i)=SHPTOT(1,i,iGau)
  548.                 SHP(2,i)=SHPTOT(2,i,iGau)
  549.               ENDDO
  550.               DXDKSI=0.
  551.               DYDKSI=0.
  552.               DO i=1,NBNO/2
  553.                 DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i)
  554.                 DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i)
  555.               ENDDO
  556.               DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau)
  557.               ESTEL=ESTEL+FACSCA*DJAC
  558.  
  559. C= 3.12.3.3 - Elements JOINTS 3D (JOT3 et JOI4)
  560.             ELSE IF (MFR.EQ.35.AND.IDIM.EQ.3) THEN
  561.               DO i=1,NBNO
  562.                 SHP(1,i)=SHPTOT(1,i,iGau)
  563.                 SHP(2,i)=SHPTOT(2,i,iGau)
  564.                 SHP(3,i)=SHPTOT(3,i,iGau)
  565.               ENDDO
  566.               IF (MELE.EQ.87) THEN
  567.                 CALL JT3LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL)
  568.                 IF (NOQUAL.EQ.1) THEN
  569.                   INTERR(1)=IB
  570.                   MOTERR(1:4)='JOT3'
  571.                   CALL ERREUR(765)
  572.                   GOTO 200
  573.                 ELSE IF (NOQUAL.EQ.2) THEN
  574.                   INTERR(1)=IB
  575.                   MOTERR(1:4)='JOT3'
  576.                   CALL ERREUR(766)
  577.                   GOTO 200
  578.                 ENDIF
  579.               ELSE IF (MELE.EQ.88) THEN
  580.                 CALL JO4LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL)
  581.                 IF (NOQUAL.EQ.1) THEN
  582.                   INTERR(1)=IB
  583.                   MOTERR(1:4)='JOI4'
  584.                   CALL ERREUR(765)
  585.                   GOTO 200
  586.                 ELSE IF (NOQUAL.EQ.2) THEN
  587.                   INTERR(1)=IB
  588.                   MOTERR(1:4)='JOI4'
  589.                   CALL ERREUR(766)
  590.                   GOTO 200
  591.                 ENDIF
  592.               ENDIF
  593.               NBNONN=NBNO/2
  594.               CALL DEVOLU(XE,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC)
  595.               IRRT=0
  596.               IF (DJAC.LT.0.) THEN
  597.                 IRRT=1
  598.               ELSE IF (DJAC.EQ.0.) THEN
  599.                 IRRT=2
  600.               ENDIF
  601.               IF (IRRT.NE.0) THEN
  602.                 CALL ERREUR(764)
  603.                 GOTO 200
  604.               ENDIF
  605.               ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  606.  
  607. C  JOINTS POREUX
  608.             ELSE IF ((MELE.GE.108.AND.MELE.LE.110).OR.
  609.      &               (MELE.GE.185.AND.MELE.LE.190)) THEN
  610.  
  611.               DO LAD=1,IDIM
  612.                 DO i=1,NBNO
  613.                   SHP(LAD,i)=SHPTOT(LAD,i,iGau)
  614.                 ENDDO
  615.               ENDDO
  616.               CALL JOPLOC(XEL,SHPTOT,NBBB,NBNO,IFOUR,XE,BPSS)
  617.               CALL DEVOLJ(XEL,XE,SHP,NBBB,NBNO,IFOUR,DJAC)
  618.               ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  619.  
  620. C= 3.12.3.4 - Elements zone cohesive ZCO2
  621.             ELSE IF (MFR.EQ.77.AND.IDIM.EQ.2) THEN
  622.               DO i=1,NBNO
  623.                 SHP(1,i)=SHPTOT(1,i,iGau)
  624.                 SHP(2,i)=SHPTOT(2,i,iGau)
  625.               ENDDO
  626.               DXDKSI=0.
  627.               DYDKSI=0.
  628.               DO i=1,NBNO
  629.                 DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i)
  630.                 DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i)
  631.               ENDDO
  632.               DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau)
  633.               ESTEL=ESTEL+FACSCA*DJAC
  634.  
  635. C= 3.12.3.3 - Elements zone cohesive ZCO3ou4
  636.             ELSE IF (MFR.EQ.77.AND.IDIM.EQ.3) THEN
  637.               DO i=1,NBNO
  638.                 SHP(1,i)=SHPTOT(1,i,iGau)
  639.                 SHP(2,i)=SHPTOT(2,i,iGau)
  640.                 SHP(3,i)=SHPTOT(3,i,iGau)
  641.               ENDDO
  642.               dXdQsi=REAL(0.D0)
  643.               dYdQsi=REAL(0.D0)
  644.               dZdQsi=REAL(0.D0)
  645.               dXdEta=REAL(0.D0)
  646.               dYdEta=REAL(0.D0)
  647.               dZdEta=REAL(0.D0)
  648.               DO i=1,NBNO
  649.                  dXdQsi=dXdQsi+SHP(2,i)*XEL(1,i)
  650.                  dXdEta=dXdEta+SHP(3,i)*XEL(1,i)
  651.                  dYdQsi=dYdQsi+SHP(2,i)*XEL(2,i)
  652.                  dYdEta=dYdEta+SHP(3,i)*XEL(2,i)
  653.                  dZdQsi=dZdQsi+SHP(2,i)*XEL(3,i)
  654.                  dZdEta=dZdEta+SHP(3,i)*XEL(3,i)
  655.               ENDDO
  656.               z = (dXdQsi*dYdEta-dXdEta*dYdQsi)
  657.               x = (dYdQsi*dZdEta-dYdEta*dZdQsi)
  658.               y = (dZdQsi*dXdEta-dZdEta*dXdQsi)
  659.               DJAC = sqrt(x*x+y*y+z*z)
  660.               IRRT=0
  661.               IF (DJAC.LT.0.) THEN
  662.                 IRRT=1
  663.               ELSE IF (DJAC.EQ.0.) THEN
  664.                 IRRT=2
  665.               ENDIF
  666.               IF (IRRT.NE.0) THEN
  667.                 CALL ERREUR(764)
  668.                 GOTO 200
  669.               ENDIF
  670.               ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  671.  
  672. C=          - Elements POI1 ou JOI1
  673.             ELSE IF ((MFR.EQ.27 .OR. MFR.EQ.75.or.
  674.      >                mfr.eq.26.or.mfr.eq.28)
  675.      >            .AND. (MELE.EQ.45 .OR. MELE.EQ.265)) THEN
  676.               ESTEL = ESTEL + (FACSCA / NBPGAU)
  677.  
  678. C= 3.12.3.4 - Autres elements
  679.             ELSE
  680.               IF (IFOMOD.EQ.2) THEN
  681.                 IDK=4
  682.               ELSE IF (IFOMOD.GE.-1.AND.IFOMOD.LE.1) THEN
  683.                 IDK=3
  684.               ELSE IF (IFOMOD.GE.3.AND.IFOMOD.LE.5) THEN
  685.                 IDK=2
  686.               ENDIF
  687.               DO j=1,NBNO
  688.                 DO i=1,IDK
  689.                   SHP(i,j)=SHPTOT(i,j,iGau)
  690.                 ENDDO
  691.               ENDDO
  692.               CALL GTEMRD(XEL,SHP,JDIM,NBNO,DJAC)
  693.               IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1.OR.
  694.      .            IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  695.                 CALL DISTRR(XEL,SHP,NBNO,RR)
  696.                 IF (IFOMOD.EQ.5) THEN
  697.                   DJAC=X4Pi*RR*RR*DJAC
  698.                 ELSE IF (IFOMOD.EQ.1.AND.NIFOUR.NE.0) THEN
  699.                   DJAC=XPi*RR*DJAC
  700.                 ELSE
  701.                   DJAC=X2Pi*RR*DJAC
  702.                 ENDIF
  703.               ENDIF
  704. C= 3.12.3.5 - Recuperation des caracteristiques selon l'element
  705. C=            En dimension 1 (1D), pas de caracteristiques actuellement
  706.               DIM3=1.
  707.               FACAR=1.
  708.               IF (IVACAR.EQ.0) GOTO 80
  709.               MPTVAL=IVACAR
  710. c                   1  2  3   4  5  6  7  8  9 10 11 12 13 14 15 16
  711.               GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4,
  712. c                   17       20       23 24 25 26 27 28 29 30       33
  713.      .               4,99,99,99,99,99, 4, 4, 4, 4,27,27,29,99,99,99,99
  714. c                      34 35             40 41 42 43 44 45 46 47 48 49
  715.      .                ,99, 4, 4, 4, 4, 4, 4,27,29,99,27,99,27,99,99,27
  716. c                      50                56 57                     65
  717.      .                ,99,99,99,99,99,99,27, 4, 4, 4, 4,4, 4, 4, 4, 4,
  718.      .               4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,4, 4,
  719.      .               4,29,99,99,99,99,99,99,99,99,27,99,99,99,99,99,99
  720.      .                ,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
  721.      .                ,99,99,99,99,99,99,99,99,27,27),MELE
  722.  99           MOTERR(1:4)=NOMTP(MELE)
  723.               MOTERR(5:12)='INTGCA'
  724.               CALL ERREUR(86)
  725.               GOTO 200
  726.  
  727. C= 3.12.3.6 - Caracteristiques pour les elements MASSIFS
  728.  4            MELVAL=IVAL(1)
  729.               IF (MELVAL.NE.0) THEN
  730.                 IGMN=MIN(iGau,VELCHE(/1))
  731.                 IBMN=MIN(IB,VELCHE(/2))
  732.                 FACAR=VELCHE(IGMN,IBMN)
  733.               ENDIF
  734.               GOTO 80
  735.  
  736. C= 3.12.3.7 - Caracteristiques pour les elements COQUES et BARRES
  737.  27           MELVAL=IVAL(1)
  738.               IGMN=MIN(iGau,VELCHE(/1))
  739.               IBMN=MIN(IB,  VELCHE(/2))
  740.               FACAR=VELCHE(IGMN,IBMN)
  741.               IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  742.                 MELVAL=IVAL(3)
  743.                 IF (MELVAL.NE.0) DIM3=VELCHE(IGMN,IBMN)
  744.               ENDIF
  745.               GOTO 80
  746.  
  747. C= 3.12.3.8 - Caracteristiques pour les elements POUTRES et TUYAUX
  748. C=            Traitement particulier pour les TUYAUX
  749.  29           DO i=1,NCARR
  750.                 IF (IVAL(i).NE.0) THEN
  751.                   MELVAL=IVAL(i)
  752.                   IGMN=MIN(iGau,VELCHE(/1))
  753.                   IBMN=MIN(IB,VELCHE(/2))
  754.                   WORK(i)=VELCHE(IGMN,IBMN)
  755.                 ENDIF
  756.               ENDDO
  757.               IF (MELE.EQ.42) THEN
  758.                 CISA= WORK(4)
  759.                 VX  = WORK(5)
  760.                 VY  = WORK(6)
  761.                 VZ  = WORK(7)
  762.                 CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  763.               ENDIF
  764.               FACAR=WORK(4)
  765. C             GOTO 80
  766.  
  767. C= 3.12.3.9 - Calcul de la composante integree en ce point de Gauss
  768.  80           DJAC  = ABS(DJAC)*POIGAU(iGau)*FACAR*DIM3
  769.               ESTEL = ESTEL+FACSCA*DJAC
  770.             ENDIF
  771.           ENDDO
  772.  
  773. C= 3.12.4 - Ajout de la contribution de cet element au resultat
  774. C=          et le cas echeant au MCHAML au centre de gravite
  775.           XRET=XRET+ESTEL
  776.           IF (KOPELE.NE.0) THEN
  777.             IBMN=MIN(IB,MELVA2.VELCHE(/2))
  778.             MELVA2.VELCHE(1,IBMN)=ESTEL
  779.           ENDIF
  780.         ENDDO
  781.  
  782. C ======
  783. C  3.13 - Desactivation/suppression de segments associes a iSou
  784. C         Sortie prematuree en cas d'ERREUR (iOK=0)
  785. C ======
  786.         iOK=1
  787.  200    SEGSUP,MWRK1
  788.         IF (LOGCOQ) THEN
  789.           SEGSUP,MWRK2
  790.           SEGSUP,MWRK3
  791.         ELSE IF (IPCHE2.NE.0) THEN
  792.           SEGSUP,MWRK3
  793.         ENDIF
  794.  
  795.  210    CALL DTMVAL(IVACAR,1)
  796.         IF (IPMEL1.NE.0) THEN
  797.           IF (ISup1.EQ.1) THEN
  798.             SEGSUP,MELVA1
  799.           ENDIF
  800.         ENDIF
  801.  230    CALL DTMVAL(IVACOM,1)
  802.  
  803.  240    CONTINUE
  804.         IF (iOK.EQ.0) THEN
  805.           IF (KOPELE.NE.0) THEN
  806.             IF (IPMEL2.NE.0) SEGSUP,MELVA2
  807.             IF (MCHAML.NE.0) SEGSUP,MCHAML
  808.             SEGSUP,MCHELM
  809.           ENDIF
  810.           GOTO 300
  811.         ENDIF
  812.  
  813.  2000 continue
  814.  
  815. C  4 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  816. C ====================================================
  817.       IRET=1
  818.       IF (KOPELE.NE.0) THEN
  819.          if( n1.ne.isouss) then
  820.            n1=isouss
  821.            SEGADJ,mchelm
  822.          endif
  823.       ENDIF
  824.  
  825.  300  NOMID =MOCOMP
  826.       NOTYPE=MOTYCO
  827.       SEGSUP,NOTYPE,NOMID
  828.  
  829. c      RETURN
  830.       END
  831.  
  832.  
  833.  
  834.  

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