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

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