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

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