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

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