Télécharger adtuy.eso

Retour à la liste

Numérotation des lignes :

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

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