Télécharger adtuy.eso

Retour à la liste

Numérotation des lignes :

adtuy
  1. C ADTUY SOURCE CB215821 17/05/02 21:15:00 9429
  2. SUBROUTINE adtuy (NEF,IPMAIL,IPINTE,IMATE,IVAMAT,NMATR,
  3. & IPMATR,NLIGR)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMCHAML
  10. -INC SMCOORD
  11. -INC SMELEME
  12. -INC SMINTE
  13. -INC SMRIGID
  14.  
  15. SEGMENT MPTVAL
  16. INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  17. CHARACTER*16 TYVAL(NCOSOU)
  18. ENDSEGMENT
  19.  
  20. SEGMENT,MMAT1
  21. REAL*8 CEL(NBNN,NBNN),XE(3,NBNN)
  22. REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN)
  23. REAL*8 FORME(NBNN),V77(NBNN)
  24. REAL*8 CMAT(NDIM,NDIM),CMAT1(IDIM,IDIM),CMAT2(IDIM,IDIM)
  25. ENDSEGMENT
  26.  
  27. C 1 - INITIALISATIONS ET VERIFICATIONS
  28. C ======================================
  29. MELEME = IPMAIL
  30. c* SEGACT,MELEME
  31. NBNN = NUM(/1)
  32. NBELEM = NUM(/2)
  33. C =====
  34. MINTE = IPINTE
  35. c* SEGACT,MINTE
  36. NBPGAU = POIGAU(/1)
  37.  
  38. C =====
  39. MPTVAL = IVAMAT
  40. c* SEGACT,MPTVAL
  41. C =====
  42. XMATRI = IPMATR
  43.  
  44. C =====
  45. C Initialisation des segments de travail
  46. C =====
  47. IF (IFOMOD.EQ.1) THEN
  48. NDIM = 3
  49. ELSE
  50. NDIM = IDIM
  51. ENDIF
  52. segini mmat1
  53. C 2 - BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IPMAIL
  54. C ============================================================
  55. DO IEL = 1, NBELEM
  56. *
  57. * MISE A ZERO DU TABLEAU CEL
  58. *
  59. CALL ZERO(CEL,NBNN,NBNN)
  60. *
  61. * COORDONNEES DES NOEUDS DE L'ELEMENT IEL DANS LE REPERE GLOBAL
  62. *
  63. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  64. *
  65. *
  66. if(nef.eq.269) then
  67. rhosv = 1.D0
  68. DO i = 1, NMATR
  69. c* IF (IVAL(i).NE.0) THEN
  70. MELVAL = IVAL(i)
  71. ibmn = MIN(iel ,VELCHE(/2))
  72. igmn = 1
  73. rhosv = rhosv * VELCHE(igmn,ibmn)
  74. c* ELSE
  75. c* VALMAT(i) = 0.D0
  76. c* ENDIF
  77. ENDDO
  78. cel(1,1)=-0.5d0*rhosv
  79. cel(1,2)= 0.5d0*rhosv
  80. cel(2,1)= cel(1,1)
  81. cel(2,2)= cel(1,2)
  82. elseif( nef.eq.270) then
  83. IFOIS = 0
  84. DO IGAU = 1, NBPGAU
  85. c calcul de la longueur ou du jacobien
  86. * dx= shptot(2,1,igau)*xe(1,1)+shptot(2,2,igau)*xe(1,2)
  87. * $ + shptot(2,3,igau)*xe(1,3)
  88. * dy= shptot(2,1,igau)*xe(2,1)+shptot(2,2,igau)*xe(2,2)
  89. * $ + shptot(2,3,igau)*xe(2,3)
  90. * dl2= dx*dx + dy * dy
  91. * if(idim.eq.3) then
  92. * dz= shptot(2,1,igau)*xe(3,1)+shptot(2,2,igau)*xe(3,2)
  93. * $ + shptot(2,3,igau)*xe(3,3)
  94. * dl2=dl2+ dz*dz
  95. * endif
  96. * djac= sqrt ( dl2)
  97.  
  98. *
  99. *- Recuperation de rho cp et section en un point de la barre
  100. *- NB : ces composantes sont obligatoires donc IVAL(i) n'est pas nul !
  101. rhsvs = 1.D0
  102. DO i = 1, NMATR
  103. c* IF (IVAL(i).NE.0) THEN
  104. MELVAL = IVAL(i)
  105. ibmn = MIN(iel ,VELCHE(/2))
  106. igmn = MIN(igau,VELCHE(/1))
  107. rhsvs= rhsvs*VELCHE(igmn,ibmn)
  108. ENDDO
  109. rhosv= rhsvs*poigau(igau)
  110. do i=1,nbnn
  111. * do j=1,idim
  112. cz= shptot(1,i,igau)* rhosv
  113.  
  114. * enddo
  115. do j=1,nbnn
  116. cel(i,j)=cel(i,j) +cz*shptot(2,j,igau)
  117. enddo
  118. enddo
  119. ENDDO
  120. endif
  121. * write(6,*) ' cel(1,)', ( cel(1,jou),jou=1,nbnn)
  122. * write(6,*) ' cel(2,)', ( cel(2,jou),jou=1,nbnn)
  123. * if(nbnn.eq.3)write(6,*) ' cel(3,)', ( cel(3,jou),jou=1,nbnn)
  124. call rempms(cel,nbnn,re(1,1,iel))
  125. enddo
  126. SEGSUP,MMAT1
  127. return
  128. end
  129.  

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