Télécharger chelco.eso

Retour à la liste

Numérotation des lignes :

  1. C CHELCO SOURCE BP208322 16/11/18 21:15:33 9177
  2. SUBROUTINE CHELCO(IVAL,IPCHEL,IPCHE1,IPCHE2,IPCHE3)
  3.  
  4. C=======================================================================
  5. C ENTREES
  6. C IVAL = 0 SI ON VEUT IDIM CHAMELEM CONTENANT CHACUN UNE COMPOSA
  7. C IVAL = 1 SI ON VEUT LA PREMIERE COMPOSANTE
  8. C IVAL = 2 SI ON VEUT LA DEUXIEME COMPOSANTE
  9. C IVAL = 3 SI ON VEUT LA TROISIEME COMPOSANTE
  10. C IPCHEL = POINTEUR SUR UN CHAMP PAR ELEMENT (TYPE MCHAML)
  11.  
  12. C SORTIES
  13. C IPCHE1 =POINTEURS SUR LES CHAMP/ELEMENT CONTENANT LES COORDONNEES
  14. C IPCHE2
  15. C IPCHE3
  16. C
  17. C EBERSOLT OCT 85
  18. C NOUVEAUX CHAMELEMS P DOWLATYARI OCT 91
  19. C=======================================================================
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8(A-H,O-Z)
  22. -INC SMCHAML
  23. -INC SMELEME
  24. -INC SMINTE
  25. -INC SMCOORD
  26. -INC CCOPTIO
  27. -INC CCGEOME
  28. CHARACTER*4 NOMEL
  29. C
  30. SEGMENT MTRA
  31. REAL*8 XE(3,NBNN)
  32. ENDSEGMENT
  33. C
  34. DATA XZER/0.D0/
  35. C
  36. C ON ACTIVE LE CHAMP/ELEMENT POUR EXTRAIRE LES INFOS NECESSAIRES
  37. C
  38. MCHEL1=IPCHEL
  39. SEGACT,MCHEL1
  40. N1=MCHEL1.INFCHE(/1)
  41. N3=MCHEL1.INFCHE(/2)
  42. L1=8
  43. NSOUS=N1
  44. C
  45. IF(IVAL.EQ.0)THEN
  46. IDEB=IDIM
  47. IFIN=1
  48. ELSE
  49. IDEB=IVAL
  50. IFIN=IVAL
  51. ENDIF
  52. C
  53. NCHE=0
  54. C
  55. C BOUCLE SUR LES COMPOSANTES
  56. C
  57. DO 1000 ICO=IDEB,IFIN,-1
  58. C
  59. C ON INITIALISE LE MCHAML CONTENANT LA COORDONNEE ICO
  60. C
  61. SEGINI,MCHELM
  62. NCHE=NCHE+1
  63. IF(NCHE.EQ.1)IPCHE1=MCHELM
  64. IF(NCHE.EQ.2)IPCHE2=MCHELM
  65. IF(NCHE.EQ.3)IPCHE3=MCHELM
  66. IFOCHE=MCHEL1.IFOCHE
  67. TITCHE='SCALAIRE'
  68. C
  69. C BOUCLE SUR LES SOUS-ZONES
  70. C
  71. DO 100 ISOUS=1,NSOUS
  72. C
  73. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  74. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  75. C
  76. DO 10 IO=1,N3
  77. INFCHE(ISOUS,IO)=MCHEL1.INFCHE(ISOUS,IO)
  78. 10 CONTINUE
  79. N2=1
  80. SEGINI MCHAML
  81. ICHAML(ISOUS)=MCHAML
  82. NOMCHE(1)='SCAL'
  83. TYPCHE(1)='REAL*8'
  84. C
  85. MELEME=IMACHE(ISOUS)
  86. SEGACT,MELEME
  87. NBELEM=NUM(/2)
  88. NBNN=NUM(/1)
  89. NOMEL=NOMS(ITYPEL)
  90. C
  91. ISUP=INFCHE(ISOUS,6)
  92. IF(ISUP.NE.1)THEN
  93. MINTE=INFCHE(ISOUS,4)
  94. SEGACT,MINTE
  95. NBPGAU=SHPTOT(/3)
  96. ELSE
  97. NBPGAU=NBNN
  98. ENDIF
  99. C
  100. N1EL=NBELEM
  101. N1PTEL=NBPGAU
  102. N2EL=0
  103. N2PTEL=0
  104. SEGINI MELVAL
  105. IELVAL(1)=MELVAL
  106. SEGINI MTRA
  107. C
  108. NBOUC=NBNN
  109. IF(NOMEL.EQ.'RAP3'.AND.ISUP.NE.1) NBOUC=6
  110. IF(NOMEL.EQ.'LIP6'.AND.ISUP.NE.1) NBOUC=12
  111. IF(NOMEL.EQ.'LIP8'.AND.ISUP.NE.1) NBOUC=16
  112.  
  113. DO 200 IB=1,NBELEM
  114. C
  115. CALL ZERO(XE,3,NBNN)
  116. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  117. C
  118. DO 200 IGAU=1,NBPGAU
  119. C
  120. IF(ISUP.NE.1)THEN
  121. XX=XZER
  122. DO 220 ID=1,NBOUC
  123. XX=XX+SHPTOT(1,ID,IGAU)*XE(ICO,ID)
  124. 220 CONTINUE
  125. ELSE
  126. XX=XE(ICO,IGAU)
  127. ENDIF
  128. C+PPj
  129. C ON DIVISE PAR 2 LE RESULTAT POUR CERTAINS ELEMENTS DE JOINTS
  130. C AM 29/3/16 UNIQUEMENT SI LE SUPPORT EST DIFFERENT DE 1
  131. IF(ISUP.NE.1) THEN
  132. IF((NOMEL.EQ.'RAC2').OR.(NOMEL.EQ.'LIA3')
  133. . .OR.(NOMEL.EQ.'LIA4').OR.(NOMEL.EQ.'LIA6').OR.(NOMEL.EQ.'LIA8')
  134. . .OR.(NOMEL.EQ.'RAP3').OR.(NOMEL.EQ.'LIP6').OR.(NOMEL.EQ.'LIP8'))
  135. . XX=XX/2
  136. ENDIF
  137. C+PPj
  138. C
  139. VELCHE(IGAU,IB)=XX
  140. C
  141. 200 CONTINUE
  142. SEGDES,MELVAL,MCHAML,MELEME
  143. IF(ISUP.NE.1)SEGDES,MINTE
  144. SEGSUP MTRA
  145. C
  146. 100 CONTINUE
  147. C
  148. SEGDES MCHELM
  149. C
  150. 1000 CONTINUE
  151. C
  152. SEGDES MCHEL1
  153. RETURN
  154. END
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  

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