Télécharger la plaquette Cast3M


fr en

Télécharger fpma1d.eso

Retour à la liste

Numérotation des lignes : 

fpma1d

  1. C FPMA1D    SOURCE    OF166741  25/02/21    21:16:41     12166          
  2.  
  3. C=======================================================================
  4. C=  Calcul des forces de pressions s'exercant sur les faces d elements =
  5. C=  massifs unidimensionnels (1D)                                      =
  6. C=                                                                     =
  7. C=  IPTVPR  Pointeur sur un MELVAL contenant les pressions appliquees  =
  8. C=          =0 si on a donne une valeur constante                      =
  9. C=  IPMAIL  Pointeur sur un MELEME de l'ENVELOPPE                      =
  10. C=  IPTINT  Pointeur sur un MINTE des caracteristiques d'integration   =
  11. C=          (ACTIF en ENTREE et en SORTIE sans modification)           =
  12. C=  IVAFOR  Pointeur sur un MPTVAL (MELVAL) contenant les forces       =
  13. C=          nodales equivalentes                                       =
  14. C=  XP      Valeur de la pression si constante                         =
  15. C=======================================================================
  16.  
  17.       SUBROUTINE FPMA1D(IPTVPR,IPMAIL,IPMAIM,IPTINT,IVAFOR,XP
  18.      &                 ,netn1,ietn1)
  19.  
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8 (A-H,O-Z)
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCREEL
  26. C= Quelques constantes (2.Pi et 4.Pi)
  27.       PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  28.       PARAMETER (X4Pi=12.566370614359172953850573533118D0)
  29.  
  30. -INC SMCHAML
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMCOORD
  34.  
  35. -INC TMPTVAL
  36.  
  37.       segment netn(notn)
  38.       segment ietn(letn)
  39.  
  40.       SEGMENT WORK
  41.         REAL*8 XE(3,NBNN)
  42.       ENDSEGMENT
  43.  
  44.       idimp1 = IDIM+1
  45. *   prob optimiseur il faut initialiser melva1
  46.       melva1 = IPTINT
  47.       IF (IPTVPR.NE.0) THEN
  48.         MELVA1=IPTVPR
  49. c*        SEGACT,MELVA1                            <- ACTIF EN E/S
  50. c*        IVA11=MELVA1.VELCHE(/1)
  51.         IVA12=MELVA1.VELCHE(/2)
  52.       ENDIF
  53.  
  54.       MINTE=IPTINT
  55. C*      SEGACT,MINTE                               <- ACTIF EN E/S
  56.       NBPGAU=POIGAU(/1)
  57.  
  58.       MELEME=IPMAIL
  59. c*      SEGACT,MELEME                              <- ACTIF EN E/S
  60.       NBNN   = meleme.NUM(/1)
  61.       NBELEM = meleme.NUM(/2)
  62.  
  63. C*OF  IF ((NBPGAU.NE.1).OR.(NBNN.NE.1)) THEN
  64. C*OF    WRITE(6,*) 'ERREUR FATALE : FPMA1D'
  65. C*OF    RETURN
  66. C*OF  ENDIF
  67.  
  68.       SEGINI,WORK
  69.  
  70.       netn = netn1
  71.       ietn = ietn1
  72.       IPT1 = IPMAIM
  73.  
  74.       IF (IPT1.GT.0) THEN
  75.         if (netn.eq.0 .or. ietn.eq.0) then
  76.           write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
  77.         endif
  78. c*        SEGACT,IPT1                                <- ACTIF en E/S
  79.         NBNN1 = ipt1.NUM(/1)
  80.         NBEL1 = ipt1.NUM(/2)
  81.       ELSE
  82.         if (netn.gt.0 .or. ietn.gt.0) then
  83.           write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
  84.         endif
  85.       ENDIF
  86.  
  87.       MPTVAL=IVAFOR
  88.       MELVAL=IVAL(1)
  89.  
  90. C= BOUCLE SUR LES ELEMENTS
  91.       DO iElt = 1, NBELEM
  92.  
  93.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,iElt,XE)
  94.  
  95.         XFLOT = +1.D0
  96.         IF (netn.GT.0) THEN
  97.           DO inf = 1, nbnn
  98.             ip = meleme.num(inf,ielt)
  99.             ideb = netn(ip)+1
  100.             ifin = netn(ip+1)
  101.             do itn = ideb, ifin
  102.               IEM = ietn(itn)
  103.               jne = 0
  104.               do i = 1, nbnn
  105.                 ino = num(i,ielt)
  106.                 do i1 = 1, nbnn1
  107.                   if (ino.eq.ipt1.num(i1,IEM)) jne=jne+1
  108.                 enddo
  109.               enddo
  110.               if (jne.eq.nbnn) goto 170
  111.             enddo
  112.           ENDDO
  113.           CALL ERREUR(26)
  114.           GOTO 9900
  115.  170      continue
  116.           XG = 0.D0
  117.           DO I = 1, NBNN1
  118.             ino = (IPT1.NUM(I,IEM)-1)*idimp1
  119.             XG=XG+XCOOR(ino+1)
  120.           ENDDO
  121.           XG=XG / NBNN1
  122.  
  123.           XK=0.D0
  124.           DO i = 1,NBNN
  125.             XK=XK+XE(1,I)
  126.           ENDDO
  127.           XK=XK/NBNN
  128.  
  129.           V_1 = XG - XK
  130.           r_z = 1.D0 / ABS(V_1)
  131.           V_1 = V_1 * r_z
  132.  
  133.           if (v_1.lt.0d0) XFLOT = -1.d0
  134.         ENDIF
  135.  
  136. C= Cas des elements AXISymetriques et SPHEriques
  137.         IF (IFOUR.GE.12.AND.IFOUR.LE.14) THEN
  138.           T1=X2Pi*XE(1,1)
  139.         ELSE IF (IFOUR.EQ.15) THEN
  140.           RR=XE(1,1)
  141.           T1=X4Pi*RR*RR
  142.         ELSE
  143.           T1=1.D0
  144.         ENDIF
  145.         IF (IPTVPR.NE.0) THEN
  146.           IEMN=MIN(iElt,IVA12)
  147.           T1=MELVA1.VELCHE(1,IEMN)*T1*xflot
  148.         ELSE
  149.           T1=XP*T1*xflot
  150.         ENDIF
  151.         VELCHE(1,iElt)=VELCHE(1,iElt)+T1
  152.       ENDDO
  153.  
  154.  9900 CONTINUE
  155.       SEGSUP,WORK
  156.  
  157. c*      SEGDES,MINTE                               <- ACTIF en E/S
  158. c*      SEGDES,MELEME                              <- ACTIF en E/S
  159. c*      IF (IPTVPR.NE.0) SEGDES,MELVA1             <- ACTIF en E/S
  160.  
  161.       RETURN
  162.       END
  163.  
  164.  
  165.  

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