Télécharger la plaquette Cast3M


fr en

Télécharger intgca.eso

Retour à la liste

Numérotation des lignes : 

intgca

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

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