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

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