Télécharger la plaquette Cast3M


fr en

Télécharger hhobsg.eso

Retour à la liste

Numérotation des lignes : 

hhobsg

  1. C HHOBSG    SOURCE    OF166741  24/05/06    21:15:07     11082          
  2. C HHOBSG    SOURCE    FANDEUR                                           
  3.  
  4. C----------------------------------------------------------------------*
  5. C Elements massifs HHO en FORMULATION 'MECANIQUE'
  6. C HHO    calcul des efforts internes (B.Sigma)
  7. C----------------------------------------------------------------------*
  8.  
  9.       SUBROUTINE HHOBSG(imoHHO, nmoFOR, IVASTR, NCSTR,
  10.      &                  IIPDPG, ADPG,BDPG,CDPG,
  11.      &                  IVACAR, NCARR, IPMINT, NBPTEL,
  12.      &                  ichDEP, ICHBSG, iret)
  13.  
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8(A-H,O-Z)
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCREEL
  20.  
  21. -INC CCHHOPA
  22. -INC CCHHOPR
  23.  
  24. -INC SMCHAML
  25. c* si besoin des coordonnees -INC SMCOORD
  26. -INC SMCHPOI
  27. -INC SMELEME
  28. -INC SMMODEL
  29. -INC SMINTE
  30. -INC SMLENTI
  31.       POINTEUR mlent4.mlenti, mlenPF.mlenti
  32. -INC SMLMOTS
  33. -INC SMLREEL
  34.       POINTEUR mlrdef.mlreel, mlrdec.mlreel, mlrmbh.mlreel
  35.  
  36.       SEGMENT MPTVAL
  37.         INTEGER IPOS(NS),NSOF(NS)
  38.         INTEGER IVAL(NCOSOU)
  39.         CHARACTER*16 TYVAL(NCOSOU)
  40.       ENDSEGMENT
  41.  
  42.       SEGMENT MWKHHO
  43.         INTEGER TABINT(NBINT)
  44.         REAL*8  TABFLO(NBFLO)
  45.       ENDSEGMENT
  46.  
  47.       LOGICAL B_GDEF, b_z
  48.       CHARACTER*(LOCHAI) chaHHO
  49.  
  50.       EXTERNAL LONG
  51.  
  52.       iret = 0
  53.  
  54.       NDPGE = 0
  55.       ADPG = XZero
  56.       BDPG = XZero
  57.       CDPG = XZero
  58.  
  59.       imodel = imoHHO
  60. c*      segact,imodel <- actif en entree/sortie
  61.  
  62. C- Premieres verifications :
  63.       CALL HHONOB(imoHHO, nobHHO, iret)
  64.       IF (nobHHO.LE.0)THEN
  65.         write(ioimp,*) 'HHOEPS: IMODEL incorrect (not HHO)'
  66.         iret = 5
  67.         RETURN
  68.       END IF
  69.  
  70. C- Recuperation des donnees de infell en entree
  71. c*      MELE   = imodel.NEFMOD
  72. c*      MFR    = imodel.infele(13)
  73.       meleme = imodel.IMAMOD
  74.       NBNOE  = meleme.NUM(/1)
  75.       NBELT  = meleme.NUM(/2)
  76.  
  77.       iva = imodel.IVAMOD(nobHHO)
  78.       CALL QUEVAL(iva,'MOT     ',iret,lenHHO,r_z,chaHHO,b_z,i_z)
  79.       B_GDEF = chaHHO(8:10).EQ.'_ft'
  80. *AV      B_GDEF = chaHHO(10:12).EQ.'_ft'
  81. c-dbg      write(ioimp,*) 'HHOBSG : je suis ici '//chaHHO(1:lenHHO),B_GDEF
  82.  
  83.       mlenti = imodel.IVAMOD(nobHHO+1)
  84. c*      segact,mlenti
  85.       mlent2 = imodel.IVAMOD(nobHHO+2)
  86. c*      segact,mlent2
  87.       mlent3 = imodel.IVAMOD(nobHHO+3)
  88. c*      segact,mlent3
  89.       mlent4 = imodel.IVAMOD(nobHHO+4)
  90. c*      segact,mlent4
  91.  
  92.       n_d_face = mlenti.lect(3)
  93.       n_d_cell = mlenti.lect(5)
  94.       nb_faces = mlenti.lect(7)
  95.       NBPGAU   = mlenti.lect(8)
  96.       idifo    = mlenti.lect(9)
  97.       NBDDL    = mlenti.lect(11)
  98.       NFORF    = idifo * n_d_face
  99.       NFORC    = idifo * n_d_cell
  100.       lhook    = 9
  101.  
  102.       nbel2 = mlent2.lect(/1) / 2
  103.       nbel3 = mlent3.lect(/1) / 2
  104.       nbfa3 = 2 * nb_faces
  105.       nbel4 = mlent4.lect(/1) / 2
  106.  
  107.       IF (mlenti.lect(6).NE.NBNOE) THEN
  108.         write(ioimp,*) 'HHOBSG: Bizarre nb_vertices'
  109.       END IF
  110.       IF (NBDDL .NE. imodel.INFELE(9)) then
  111.         write(ioimp,*) 'HHOBSG: Bizarre NBDDL'
  112.       END IF
  113. c NBPGAU =? (NBPTEL = imodel.INFELE(4))
  114.       IF (NBPGAU .NE. imodel.INFELE(4)) then
  115.         write(ioimp,*) 'HHOBSG: Bizarre nb.p.gau(1)'
  116.       END IF
  117. c NBPGAU =? minte.POIGAU(/1)
  118.       minte = IPMINT
  119. c*      SEGACT minte <- actif en E/S
  120.       if (NBPGAU .NE. minte.POIGAU(/1)) then
  121.         write(ioimp,*) 'HHOBSG: Bizarre nb.p.gau (2)'
  122.       end if
  123. c-dbg      write(ioimp,*) 'HHOBSG nbpgau=',NBPGAU
  124. c-dbg      write(ioimp,*) 'HHOBSG: dof face/cell',n_d_face,n_d_cell,nb_faces
  125.       if (nbel3.NE.(NBELT*nb_faces)) then
  126.         write(ioimp,*) 'HHOBSG: Bizarre nbel3'
  127.       end if
  128.       if (nbel4.NE.NBELT) then
  129.         write(ioimp,*) 'HHOBSG: Bizarre nbel4'
  130.       end if
  131.  
  132. C- Verification des caracteristiques :
  133.       mptval = IVACAR
  134.       IVPIHO = mptval.IVAL(NCARR-1)
  135.       melval = IVPIHO
  136.       IGPI = melval.VELCHE(/1)
  137.       IEPI = melval.VELCHE(/2)
  138. c-dbg      write(ioimp,*) 'IVPIHO',melval,igpi,iepi,tyval(ncarr-1)
  139.       IF (IGPI.NE.NBPGAU .AND. IGPI.NE.1) THEN
  140.         write(ioimp,*) 'HHOBSG: PIHO vector size incorrect'
  141.         iret = 21
  142.         RETURN
  143.       END IF
  144.       IVMBHO = mptval.IVAL(NCARR)
  145.       melval = IVMBHO
  146.       IGMB = melval.IELCHE(/1)
  147.       IEMB = melval.IELCHE(/2)
  148. c-dbg      write(ioimp,*) 'IVMBHO',melval,igmb,iemb,tyval(ncarr)
  149.       mlrmbh = melval.IELCHE(1,1)
  150. c*      segact,mlrmbh
  151. c*      write(ioimp,*) 'HHOBSG MBHHO SIZE:',mlrmbh.prog(/1),
  152. c*     &               NBDDL,9*NBDDL,mlenti.lect(14)
  153.       IF ((mlrmbh.prog(/1).NE.(9*NBDDL)) .OR. 
  154.      &    (mlrmbh.prog(/1).NE.mlenti.lect(14))) THEN
  155.         write(ioimp,*) 'HHOBSG: BHHO matrix size incorrect'
  156.         iret = 21
  157.         RETURN
  158.       END IF
  159.  
  160. C- Forces des faces et des cellules :
  161.       nomid = nmoFOR
  162. c      segact,nomid
  163. c-dbg      write(ioimp,*) 'HHOBSG=',NFORC,NFORF,lesobl(/2),lesfac(/2)
  164.       nfac = 0
  165.       JGN = nomid.lesobl(/1)
  166.  
  167. C- Le chapeau du champ point de forces interieures
  168.       NAT = 2
  169.       NSOUPO = 2
  170.       SEGINI,MCHPOI
  171.       mchpoi.MTYPOI = 'FORCES  '
  172.       mchpoi.MOCHDE = '  '
  173.       mchpoi.JATTRI(1) = 2
  174.       mchpoi.JATTRI(2) = 0
  175.       mchpoi.IFOPOI = IFOUR
  176.       ICHBSG = MCHPOI
  177.  
  178. C- 2 sous-zones : les points supports des cellules et des faces
  179.       NC = NFORC
  180.       N = nbel4
  181.       SEGINI,MSOUP1
  182.       SEGINI,MPOVA1
  183.       DO i = 1, NC
  184.         msoup1.NOCOMP(i) = '        '
  185.         msoup1.NOCOMP(i)(1:JGN) = nomid.lesobl(i)(1:JGN)
  186.         msoup1.NOHARM(i) = 0
  187.       END DO
  188.       msoup1.IPOVAL = MPOVA1
  189.       CALL HHOMPO('CELL',mlent4,IPT1)
  190.       msoup1.IGEOC  = IPT1
  191.       mchpoi.IPCHP(1) = MSOUP1
  192.  
  193.       NC = NFORF
  194.       N = nbel2
  195.       SEGINI,MSOUP2
  196.       SEGINI,MPOVA2
  197.       DO i = 1, NC
  198.         msoup2.NOCOMP(i) = '        '
  199.         msoup2.NOCOMP(i)(1:JGN) = nomid.lesobl(NFORC+i)(1:JGN)
  200.         msoup2.NOHARM(i) = 0
  201.       END DO
  202.       msoup2.IPOVAL = MPOVA2
  203.       CALL HHOMPO('FACE',mlent2,IPT2)
  204.       msoup2.IGEOC  = IPT2
  205.       mchpoi.IPCHP(2) = MSOUP2
  206.  
  207. C- La liste mlenPF devrait etre initialisee une seule fois et remplie
  208.       CALL HHOMPO('LGFA',mlent2,mlenPF)
  209.       IPT4 = MPFHHO
  210. c      segact,ipt4
  211.  
  212. C- Le modele est en grandes deformations : Il donc transporter le 
  213. C- tenseur des contraintes (de Cauchy SIGC) sur la geometrie initiale 
  214. C- (tenseur de Piola-Kirchhoff 1 = PK1) PK1 = SIGC.[det(F).inv(transF)] 
  215.       IF ( B_GDEF ) THEN
  216.         NDEPC = NFORC
  217.         NDEPF = NFORF
  218.         nomid = imodel.LNOMID(1)
  219.         if (nomid.eq.0) then
  220.           write(ioimp,*) 'HHOBSG - IMODEL - MODEPL incorrect'
  221.           iret = 5
  222.           return
  223.         end if
  224. c*        segact,nomid
  225.         JGN = nomid.lesobl(/1)
  226.         ivid = 1
  227. C- Deplacements des faces et des cellules :
  228. c-dbg      write(ioimp,*) 'HHOBSG=',NDEPC,NDEPF,lesobl(/2),lesfac(/2)
  229.         nfac = 0
  230. C Deplacements des cellules - Points supports des cellules
  231.         JGM = NDEPC + nfac
  232.         SEGINI,mlmots
  233.         DO i = 1, NDEPC
  234.           mlmots.MOTS(i)(1:JGN) = nomid.lesobl(i)(1:JGN)
  235.         END DO
  236.         CALL EXTR23(ichDEP,mlmots,MPCHHO,mlrDEC,ivid)
  237.         SEGACT,mlrDEC
  238. C Deplacements des faces - Points supports des faces
  239.         JGM = NDEPF + nfac
  240.         SEGADJ,mlmots
  241.         DO i = 1, NDEPF
  242.           mlmots.MOTS(i)(1:JGN) = nomid.lesobl(NDEPC+i)(1:JGN)
  243.         END DO
  244.         CALL EXTR23(ichDEP,mlmots,MPFHHO,mlrDEF,ivid)
  245.         SEGACT,mlrDEF
  246.       END IF
  247.  
  248. C- Indices et tableau de travail
  249.       ir_coo =          0
  250. c* si besoin des coordonnees      ir_sig = ir_coo + (IDIM*NBNOE)
  251.       ir_sig = ir_coo + 0
  252. c* si besoin des contraintes      ir_fce = ir_sig + lhook
  253.       ir_fce = ir_sig + 0
  254.       ir_ffa = ir_fce + NFORC
  255.       ir_fge = ir_ffa + (NFORF*nb_faces)
  256.       ir_fin = ir_fge + NDPGE
  257.       IF (B_GDEF) THEN
  258.         ir_gra = ir_fin
  259. c* si besoin des gradients        ir_uce = ir_gra + lhook
  260.         ir_uce = ir_gra + 0
  261.         ir_ufa = ir_uce + NDEPC
  262.         ir_uge = ir_ufa + (NDEPF*nb_faces)
  263.         ir_fin = ir_uge + NDPGE
  264.       END IF
  265.  
  266.       NBINT = nb_faces
  267.       NBFLO = ir_fin
  268.       SEGINI,MWKHHO
  269.  
  270. C Pour l'instant NDPGE = 0, a recuperer dans ichDEP ?
  271.       IF (NDPGE.GT.0) THEN
  272.         DO ic = 1, NDPGE
  273. ccc?          TABFLO(ir_fge+ic) = XZero
  274. ccc?          TABFLO(ir_uge+ic) = A recuperer dans ichDEP
  275.         END DO
  276.       END IF
  277. c* si besoin des coordonnees        SEGACT,mcoord*nomod
  278.  
  279. C-------------------------
  280. C Boucle sur les elements
  281. C-------------------------
  282.       DO IEL = 1, NBELT
  283.  
  284. C- Recuperation des coordonnees des noeuds de l element IEL
  285. c*        CALL HHOCOO(meleme.num,NBNOE, mcoord.xcoor, IEL,
  286. c*    &               TABFLO(ir_coo+1), iret)
  287. c*        IF (iret.NE.0) RETURN
  288.  
  289. C- Reperage des faces :
  290.         in1 = (IEL-1) * nbfa3
  291.         DO j1 = 1, nb_faces
  292.           in2 = in1 + (2 * j1)
  293.           je = mlent3.lect(in2-1)
  294.           ip = ABS(mlent3.lect(in2))
  295. c-dbg      if (ip.eq.0) write(ioimp,*) 'HHOEPS IFAE Bizarre...',iel,j1,je,ip
  296.           TABINT(j1) = ip + NBFHHO(je-1)
  297.         END DO
  298. C- Remise a zero des forces
  299.         DO jc = ir_fce+1, ir_fge
  300.           TABFLO(jc) = XZero
  301.         END DO
  302. C- Valeurs des inconnues primales pour l'element IEL (cell+faces)
  303.         IF (B_GDEF) THEN
  304.           in1 = IEL * 2
  305.           je = mlent4.lect(in1-1)
  306.           ip = mlent4.lect(in1)
  307. c-dbg      if (ip.le.0) write(ioimp,*) 'HHOBSG ICEL Bizarre...',iel,je,ip
  308.           jp = ip + NBCHHO(je-1)
  309. c-dbg      write(ioimp,*) 'HHOBSG ICEL :',iel,je,ip,jp
  310. c-dbg      write(ioimp,*) 'HHOBSG      :',NDEPC,NCEHHO,ir_uce
  311. c-dbg      write(ioimp,*) 'HHOBSG      :',NDEPF,NFAHHO,ir_ufa
  312.           DO ic = 1, NDEPC
  313.             jc = NCEHHO * (ic - 1)
  314. c-dbg      write(ioimp,*) 'HHOBSG    ic:',ic,jc,jp,mlrDEC.prog(/1),
  315. c-dbg     &             TABFLO(/1),ir_uce+ic,jp+jc
  316.             TABFLO(ir_uce + ic) = mlrDEC.prog(jp + jc)
  317.           END DO
  318.           ir_kc = ir_ufa
  319.           DO j1 = 1, nb_faces
  320.             jp = TABINT(j1)
  321.             DO ic = 1, NDEPF
  322.               jc = NFAHHO * (ic - 1)
  323.               TABFLO(ir_kc + ic) = mlrDEF.prog(jp + jc)
  324.             END DO
  325.             ir_kc = ir_kc + NDEPF
  326.           END DO
  327.         END IF
  328.  
  329.         JEPI = MIN(IEL,IEPI)
  330.         JEMB = MIN(IEL,IEMB)
  331. C--  --  --  --  --  --  --  --  --
  332. C - Boucle sur les points de Gauss
  333. C--  --  --  --  --  --  --  --  --
  334.         DO IGAU = 1, NBPGAU
  335.  
  336.           melval = IVPIHO
  337.           JGPI = MIN(IGAU,IGPI)
  338.           pgau = melval.VELCHE(JGPI,JEPI)
  339.  
  340.           melval = IVMBHO
  341.           JGMB = MIN(IGAU,IGMB)
  342.           mlrmbh = melval.IELCHE(JGMB,JEMB)
  343. c*          segact,mlrmbh
  344. c* !! matrice BHHO stockee colonne par colonne : lhook*NBDDL
  345.  
  346. C -- Recuperation des "contraintes" de Cauchy
  347.           mptval = IVASTR
  348. C -- Contraintes "Diagonales" SIG(11,22,33)
  349.           melval = mptval.IVAL(1)
  350.           IEMN = MIN(IEL ,melval.VELCHE(/1))
  351.           IGMN = MIN(IGAU,melval.VELCHE(/2))
  352.           SIGC11 = melval.velche(IGMN,IEMN)
  353.           melval = mptval.IVAL(2)
  354.           IEMN = MIN(IEL ,melval.VELCHE(/1))
  355.           IGMN = MIN(IGAU,melval.VELCHE(/2))
  356.           SIGC22 = melval.velche(IGMN,IEMN)
  357.           melval = mptval.IVAL(3)
  358.           IEMN = MIN(IEL ,melval.VELCHE(/1))
  359.           IGMN = MIN(IGAU,melval.VELCHE(/2))
  360.           SIGC33 = melval.velche(IGMN,IEMN)
  361. C -- Contraintes de cisaillement SIG(12,13,23)
  362.           melval = mptval.IVAL(4)
  363.           IEMN = MIN(IEL ,melval.VELCHE(/1))
  364.           IGMN = MIN(IGAU,melval.VELCHE(/2))
  365.           SIGC12 = melval.velche(IGMN,IEMN)
  366.           IF (NCSTR.GT.4) THEN
  367.             melval = mptval.IVAL(5)
  368.             IEMN = MIN(IEL ,melval.VELCHE(/1))
  369.             IGMN = MIN(IGAU,melval.VELCHE(/2))
  370.             SIGC13 = melval.velche(IGMN,IEMN)
  371.             melval = mptval.IVAL(6)
  372.             IEMN = MIN(IEL ,melval.VELCHE(/1))
  373.             IGMN = MIN(IGAU,melval.VELCHE(/2))
  374.             SIGC23 = melval.velche(IGMN,IEMN)
  375.           ELSE
  376.             SIGC13 = XZero
  377.             SIGC23 = XZero
  378.           END IF
  379.           SIGC21 = SIGC12
  380.           SIGC31 = SIGC13
  381.           SIGC32 = SIGC23
  382.  
  383. c* !! matrice BHHO stockee colonne par colonne : lhook*NBDDL
  384.           IF ( B_GDEF ) THEN
  385. C- Il faut calculer le tenseurs des contraintes de Piola-Kirchhoff 1
  386. C- F = gradient_transformation
  387.             F11 = 1.D0
  388.             F22 = 1.D0
  389.             F33 = 1.D0
  390.             F12 = XZero
  391.             F21 = XZero
  392.             F13 = XZero
  393.             F31 = XZero
  394.             F23 = XZero
  395.             F32 = XZero
  396.             DO jc = 1, NBDDL
  397.               jnc = lhook * (jc-1)
  398.               r_z = TABFLO(ir_uce + jc)
  399.               F11 = F11 + mlrmbh.prog(1 + jnc) * r_z
  400.               F22 = F22 + mlrmbh.prog(2 + jnc) * r_z
  401.               F33 = F33 + mlrmbh.prog(3 + jnc) * r_z
  402.               F12 = F12 + mlrmbh.prog(4 + jnc) * r_z
  403.               F21 = F21 + mlrmbh.prog(5 + jnc) * r_z
  404.               F13 = F13 + mlrmbh.prog(6 + jnc) * r_z
  405.               F31 = F31 + mlrmbh.prog(7 + jnc) * r_z
  406.               F23 = F23 + mlrmbh.prog(8 + jnc) * r_z
  407.               F32 = F32 + mlrmbh.prog(9 + jnc) * r_z
  408.             END DO
  409. c- DIFT = det(F).inv(trans(F))
  410.             DIFT11 = F22*F33 - F32*F23
  411.             DIFT12 = F31*F23 - F21*F33
  412.             DIFT13 = F21*F32 - F31*F22
  413.             DIFT21 = F32*F13 - F12*F33
  414.             DIFT22 = F11*F33 - F31*F13
  415.             DIFT23 = F31*F12 - F11*F32
  416.             DIFT31 = F12*F23 - F22*F13
  417.             DIFT32 = F21*F13 - F11*F23
  418.             DIFT33 = F11*F22 - F21*F12
  419. c- Contraintes de Piola-Kirchhoff 1 : PIKU = SIGC.DIFT
  420.             PIKU11 = SIGC11 * DIFT11 + SIGC12 * DIFT21 + SIGC13 * DIFT31
  421.             PIKU22 = SIGC21 * DIFT12 + SIGC22 * DIFT22 + SIGC23 * DIFT32
  422.             PIKU33 = SIGC31 * DIFT13 + SIGC32 * DIFT23 + SIGC33 * DIFT33
  423.             PIKU12 = SIGC11 * DIFT12 + SIGC12 * DIFT22 + SIGC13 * DIFT32
  424.             PIKU21 = SIGC21 * DIFT11 + SIGC22 * DIFT21 + SIGC23 * DIFT31
  425.             PIKU13 = SIGC11 * DIFT13 + SIGC12 * DIFT23 + SIGC13 * DIFT33
  426.             PIKU31 = SIGC31 * DIFT11 + SIGC32 * DIFT21 + SIGC33 * DIFT31
  427.             PIKU23 = SIGC21 * DIFT13 + SIGC22 * DIFT23 + SIGC23 * DIFT33
  428.             PIKU32 = SIGC31 * DIFT12 + SIGC32 * DIFT22 + SIGC33 * DIFT32
  429. c* !! matrice BHHO stockee colonne par colonne : lhook*NBDDL
  430.             DO jc = 1, NBDDL
  431.               jnc = lhook * (jc-1)
  432.               r_z =   mlrmbh.prog(1 + jnc) * PIKU11
  433.      &              + mlrmbh.prog(2 + jnc) * PIKU22
  434.      &              + mlrmbh.prog(3 + jnc) * PIKU33
  435.      &              + mlrmbh.prog(4 + jnc) * PIKU12
  436.      &              + mlrmbh.prog(5 + jnc) * PIKU21
  437.               IF (NCSTR.GT.4) THEN
  438.                 r_z = r_z + mlrmbh.prog(6 + jnc) * PIKU13
  439.      &                    + mlrmbh.prog(7 + jnc) * PIKU31
  440.      &                    + mlrmbh.prog(8 + jnc) * PIKU23
  441.      &                    + mlrmbh.prog(9 + jnc) * PIKU32
  442.               END IF
  443.               TABFLO(ir_fce + jc) = TABFLO(ir_fce + jc) + pgau * r_z
  444.             END DO
  445.           ELSE
  446.             DO jc = 1, NBDDL
  447.               jnc = lhook * (jc-1)
  448.               r_z =   mlrmbh.prog(1 + jnc) * SIGC11
  449.      &              + mlrmbh.prog(2 + jnc) * SIGC22
  450.      &              + mlrmbh.prog(3 + jnc) * SIGC33
  451.      &              + mlrmbh.prog(4 + jnc) * SIGC12
  452.      &              + mlrmbh.prog(5 + jnc) * SIGC21
  453.               IF (NCSTR.GT.4) THEN
  454.                 r_z = r_z + mlrmbh.prog(6 + jnc) * SIGC13
  455.      &                    + mlrmbh.prog(7 + jnc) * SIGC31
  456.      &                    + mlrmbh.prog(8 + jnc) * SIGC23
  457.      &                    + mlrmbh.prog(9 + jnc) * SIGC32
  458.               END IF
  459.               TABFLO(ir_fce + jc) = TABFLO(ir_fce + jc) + pgau * r_z
  460.             END DO
  461.           END IF
  462.  
  463. C--  --  --  --  --  --  --  --  --
  464.         END DO
  465. C--  --  --  --  --  --  --  --  --
  466.  
  467. C Pour les cellules
  468. c-dbg      write(ioimp,*) 'mpova1',iel,NBELT,nbel4,ir_fce
  469.         DO ic = 1, NFORC
  470.           mpova1.VPOCHA(IEL,ic) =   mpova1.VPOCHA(IEL,ic)
  471.      &                            + TABFLO(ir_fce + ic)
  472.         END DO
  473. C Pour les faces
  474.         ir_kc = ir_ffa
  475.         DO j1 = 1, nb_faces
  476.           jp = TABINT(j1)
  477.           kp = ipt4.num(1,jp)
  478.           IFA = mlenPF.lect(kp)
  479. c-dbg      write(ioimp,*) 'mpova2',iel,j1,nb_faces,kp,IFA,nbel2,ir_kc
  480.           DO ic = 1, NFORF
  481.             mpova2.VPOCHA(IFA,ic) =   mpova2.VPOCHA(IFA,ic)
  482.      &                              + TABFLO(ir_kc + ic)
  483.           END DO
  484.           ir_kc = ir_kc + NFORF
  485.         END DO
  486.  
  487. C-------------------------
  488.       END DO
  489. C-------------------------
  490.       SEGSUP,MWKHHO
  491.       SEGSUP,mlenPF
  492.       IF ( B_GDEF ) THEN
  493.         SEGSUP,mlrDEC,mlrDEF
  494.         SEGSUP,mlmots
  495.       END IF
  496.  
  497. c*      RETURN
  498.       END
  499.  
  500.  
  501.  

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