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

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