Télécharger fpma1d.eso

Retour à la liste

Numérotation des lignes :

fpma1d
  1. C FPMA1D SOURCE OF166741 25/02/06 21:15:03 12146
  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. segment netn(notn)
  36. segment ietn(letn)
  37.  
  38. SEGMENT WORK
  39. REAL*8 XE(3,NBNN)
  40. ENDSEGMENT
  41.  
  42. SEGMENT MPTVAL
  43. INTEGER IPOS(NS),NSOF(NS)
  44. INTEGER IVAL(NCOSOU)
  45. CHARACTER*16 TYVAL(NCOSOU)
  46. ENDSEGMENT
  47.  
  48. idimp1 = IDIM+1
  49. * prob optimiseur il faut initialiser melva1
  50. melva1 = IPTINT
  51. IF (IPTVPR.NE.0) THEN
  52. MELVA1=IPTVPR
  53. c* SEGACT,MELVA1 <- ACTIF EN E/S
  54. c* IVA11=MELVA1.VELCHE(/1)
  55. IVA12=MELVA1.VELCHE(/2)
  56. ENDIF
  57.  
  58. MINTE=IPTINT
  59. C* SEGACT,MINTE <- ACTIF EN E/S
  60. NBPGAU=POIGAU(/1)
  61.  
  62. MELEME=IPMAIL
  63. c* SEGACT,MELEME <- ACTIF EN E/S
  64. NBNN = meleme.NUM(/1)
  65. NBELEM = meleme.NUM(/2)
  66.  
  67. C*OF IF ((NBPGAU.NE.1).OR.(NBNN.NE.1)) THEN
  68. C*OF WRITE(6,*) 'ERREUR FATALE : FPMA1D'
  69. C*OF RETURN
  70. C*OF ENDIF
  71.  
  72. SEGINI,WORK
  73.  
  74. netn = netn1
  75. ietn = ietn1
  76. IPT1 = IPMAIM
  77.  
  78. IF (IPT1.GT.0) THEN
  79. if (netn.eq.0 .or. ietn.eq.0) then
  80. write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
  81. endif
  82. c* SEGACT,IPT1 <- ACTIF en E/S
  83. NBNN1 = ipt1.NUM(/1)
  84. NBEL1 = ipt1.NUM(/2)
  85. ELSE
  86. if (netn.gt.0 .or. ietn.gt.0) then
  87. write(ioimp,*) 'FPMA1D : incompatibilite netn, ietn & IPMAIM'
  88. endif
  89. ENDIF
  90.  
  91. MPTVAL=IVAFOR
  92. MELVAL=IVAL(1)
  93.  
  94. C= BOUCLE SUR LES ELEMENTS
  95. DO iElt = 1, NBELEM
  96.  
  97. CALL DOXE(XCOOR,IDIM,NBNN,NUM,iElt,XE)
  98.  
  99. XFLOT = +1.D0
  100. IF (netn.GT.0) THEN
  101. DO inf = 1, nbnn
  102. ip = meleme.num(inf,ielt)
  103. ideb = netn(ip)+1
  104. ifin = netn(ip+1)
  105. do itn = ideb, ifin
  106. IEM = ietn(itn)
  107. jne = 0
  108. do i = 1, nbnn
  109. ino = num(i,ielt)
  110. do i1 = 1, nbnn1
  111. if (ino.eq.ipt1.num(i1,IEM)) jne=jne+1
  112. enddo
  113. enddo
  114. if (jne.eq.nbnn) goto 170
  115. enddo
  116. ENDDO
  117. CALL ERREUR(26)
  118. GOTO 9900
  119. 170 continue
  120. XG = 0.D0
  121. DO I = 1, NBNN1
  122. ino = (IPT1.NUM(I,IEM)-1)*idimp1
  123. XG=XG+XCOOR(ino+1)
  124. ENDDO
  125. XG=XG / NBNN1
  126.  
  127. XK=0.D0
  128. DO i = 1,NBNN
  129. XK=XK+XE(1,I)
  130. ENDDO
  131. XK=XK/NBNN
  132.  
  133. V_1 = XG - XK
  134. r_z = 1.D0 / ABS(V_1)
  135. V_1 = V_1 * r_z
  136.  
  137. if (v_1.lt.0d0) XFLOT = -1.d0
  138. ENDIF
  139.  
  140. C= Cas des elements AXISymetriques et SPHEriques
  141. IF (IFOUR.GE.12.AND.IFOUR.LE.14) THEN
  142. T1=X2Pi*XE(1,1)
  143. ELSE IF (IFOUR.EQ.15) THEN
  144. RR=XE(1,1)
  145. T1=X4Pi*RR*RR
  146. ELSE
  147. T1=1.D0
  148. ENDIF
  149. IF (IPTVPR.NE.0) THEN
  150. IEMN=MIN(iElt,IVA12)
  151. T1=MELVA1.VELCHE(1,IEMN)*T1*xflot
  152. ELSE
  153. T1=XP*T1*xflot
  154. ENDIF
  155. VELCHE(1,iElt)=VELCHE(1,iElt)+T1
  156. ENDDO
  157.  
  158. 9900 CONTINUE
  159. SEGSUP,WORK
  160.  
  161. c* SEGDES,MINTE <- ACTIF en E/S
  162. c* SEGDES,MELEME <- ACTIF en E/S
  163. c* IF (IPTVPR.NE.0) SEGDES,MELVA1 <- ACTIF en E/S
  164.  
  165. RETURN
  166. END
  167.  
  168.  
  169.  

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