Télécharger chaspg.eso

Retour à la liste

Numérotation des lignes :

  1. C CHASPG SOURCE CB215821 15/02/03 21:15:03 8363
  2. SUBROUTINE CHASPG(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
  3. C---------------------------------------------------------------------
  4. C
  5. C ENTREES:
  6. C
  7. C IPMODL Pointeur sur un MMODEL de type NAVIER_STOKES
  8. C IPOI1 Pointeur sur un MCHAML
  9. C IPLAC Indique le type de support demandé :
  10. C 1 scalaire aux NOEUDS
  11. C 2 scalaire au CENTRE DE GRAVITE
  12. C 3 scalaire aux points d'integration de la RAIDEUR
  13. C 4 scalaire aux points d'integration de la MASSE
  14. C 5 scalaire aux points de CONTRAINTES
  15. C 6 (utilisé dans le cas de la thermique)
  16. C 7 SPG : FACE
  17. C 8 SPG : CENTREP1
  18. C 9 SPG : MSOMMET
  19. C TYPPROJ Mot designant le type transformation autre-->sommet
  20. C INTERP pour interpolation
  21. C PROJEC pour projection
  22. C
  23. C SORTIE:
  24. C
  25. C IPOI2 Pointeur sur un MCHAML
  26. C IRET =0 Si tout est ok
  27. C Sinon contient le numero d'erreur
  28. C
  29. C A.BLEYER le 22/01/2004
  30. C
  31. C---------------------------------------------------------------------
  32. IMPLICIT REAL*8(A-H,O-Z)
  33. -INC CCOPTIO
  34. -INC SMMODEL
  35. -INC SMCHAML
  36. -INC SMELEME
  37. -INC SMINTE
  38. -INC SMCOORD
  39.  
  40. PARAMETER (NSPG = 9)
  41. CHARACTER*8 LSPG(NSPG)
  42. C
  43. SEGMENT SWORK
  44. REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
  45. REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
  46. ENDSEGMENT
  47. C
  48. C NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
  49. C N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
  50. C
  51. SEGMENT INFO
  52. INTEGER INFELL(JG)
  53. ENDSEGMENT
  54.  
  55. POINTEUR INFO1.INFO
  56. C
  57. IRET=0
  58.  
  59. LSPG(1)='NOEUD'
  60. LSPG(2)='GRAVITE'
  61. LSPG(3)='RIGIDITE'
  62. LSPG(4)='MASSE'
  63. LSPG(5)='STRESSES'
  64. LSPG(6)='THERMIQU'
  65. LSPG(7)='FACE'
  66. LSPG(8)='P1CENTRE'
  67. LSPG(9)='MSOMMET'
  68.  
  69. C
  70. C ACTIVATION DU MODELE
  71. C
  72. MMODEL=IPMODL
  73. CALL LEKMOD(MMODEL,IDOMA,INEFMD)
  74. SEGACT MMODEL
  75. NSOUS1=KMODEL(/1)
  76. C
  77. C ACTIVATION DES MCHELM
  78. C
  79. MCHEL1 =IPOI1
  80. SEGACT MCHEL1
  81. NSOUS=MCHEL1.ICHAML(/1)
  82. IF(NSOUS.GT.NSOUS1)THEN
  83. IRET=553
  84. SEGDES MMODEL,MCHEL1
  85. RETURN
  86. ENDIF
  87. N1=NSOUS
  88. L1=MCHEL1.TITCHE(/1)
  89. N3=MCHEL1.INFCHE(/2)
  90. NINF=N3
  91. IF (N3.LT.6) N3=6
  92. SEGINI MCHELM
  93. TITCHE=MCHEL1.TITCHE
  94. IFOCHE=IFOUR
  95. IPOI2=MCHELM
  96. C
  97. C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
  98. C
  99. C NTEL=0
  100. C KK1=0
  101. DO 100 ISOUS=1,NSOUS
  102. C
  103. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  104. DO 191 IP=1,NINF
  105. INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
  106. 191 CONTINUE
  107. MINTE1=MCHEL1.INFCHE(ISOUS,4)
  108. IPLAC1=MCHEL1.INFCHE(ISOUS,6)
  109.  
  110. IMODEL=KMODEL(ISOUS)
  111. SEGACT IMODEL
  112. MELE=NEFMOD
  113.  
  114. IF (IPLAC1.EQ.IPLAC) THEN
  115. SEGDES MMODEL,MCHEL1,MCHELM,IMODEL
  116. IPOI2=IPOI1
  117. RETURN
  118. ELSEIF (IPLAC1.EQ.1.AND.IPLAC1.NE.IPLAC) THEN
  119. IF (IPLAC.EQ.2) THEN
  120. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  121. ELSEIF(IPLAC.EQ.8) THEN
  122. IF (MELE.GE.223.AND.MELE.LE.236) THEN
  123. CALL LEKTAB(IDOMA,'MACRO1',IPT1)
  124. ELSE
  125. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  126. ENDIF
  127. CALL LEKTAB(IDOMA,'ELTP1NC',IPT2)
  128. C KK1=1
  129. ELSEIF(IPLAC.EQ.9) THEN
  130. IF (MELE.GE.223.AND.MELE.LE.236) THEN
  131. CALL LEKTAB(IDOMA,'MACRO1',IPT1)
  132. ELSE
  133. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  134. ENDIF
  135. ENDIF
  136. ELSEIF (IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN
  137. IF (MELE.GE.223.AND.MELE.LE.236) THEN
  138. CALL LEKTAB(IDOMA,'MACRO1',IPT1)
  139. ELSE
  140. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  141. ENDIF
  142. ELSEIF (IPLAC1.NE.1.AND.IPLAC.NE.1) THEN
  143. WRITE(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible'
  144. WRITE(6,*)'avec ',LSPG(IPLAC)
  145. WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!'
  146. SEGDES MMODEL,MCHEL1,MCHELM,IMODEL
  147. RETURN
  148. ENDIF
  149.  
  150. SEGACT IPT1
  151. IF(NSOUS.NE.1) THEN
  152. MELEME=IPT1.LISOUS(ISOUS)
  153. SEGACT MELEME
  154. ELSE
  155. MELEME=IPT1
  156. ENDIF
  157.  
  158. IMACHE(ISOUS)=MELEME
  159. C
  160. C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
  161. C
  162. info=0
  163. if(infmod(/1).lt.2+iplac) then
  164. CALL ELQUOI(MELE,0,IPLAC,IPTR2,IMODEL)
  165. IF ( IERR .NE. 0) GOTO 665
  166. INFO=IPTR2
  167. MELGEO=INFELL(14)
  168. MINTE=INFELL(11)
  169. ELSE
  170. MINTE=infmod(2+iplac)
  171. MELGEO=INFELE(14)
  172. ENDIF
  173.  
  174. INFCHE(ISOUS,4)=MINTE
  175. IF(IPLAC.EQ.1)INFCHE(ISOUS,4)=0
  176. INFCHE(ISOUS,6)=IPLAC
  177. C
  178. C ON RECUPERE LE NOMBRE D ELEMENTS
  179. C
  180. NBNN =NUM(/1)
  181. NEL =NUM(/2)
  182. C WRITE(6,*)'NBNN=',NBNN,'NEL=',NEL
  183. C
  184. C ON RECUPERE LE NOMBRE DE POINTS SUPPORT
  185. C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
  186. C
  187. INFO1=0
  188. IF(MINTE1.EQ.0)THEN
  189. if(infmod(/1).lt.2+iplac1) then
  190. CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
  191. INFO1=IPTR2
  192. MINTE1=INFO1.INFELL(11)
  193. ELSE
  194. minte1=infmod(2+iplac1)
  195. endif
  196. ENDIF
  197. SEGACT MINTE1
  198. NBN1=MINTE1.SHPTOT(/2)
  199.  
  200. SEGACT MINTE
  201. NBN2=SHPTOT(/2)
  202. IF(IPLAC.EQ.2) NBN2=1
  203.  
  204. C WRITE(6,*)'NBN1=',NBN1,'NBN2=',NBN2
  205. SEGINI SWORK
  206. C
  207. C CREATION DU MCHAML
  208. C
  209. MCHAM1=MCHEL1.ICHAML(ISOUS)
  210. SEGACT MCHAM1
  211. N2=MCHAM1.NOMCHE(/2)
  212. SEGINI MCHAML
  213. ICHAML(ISOUS)=MCHAML
  214. C
  215. C BOUCLE SUR LES COMPOSANTES
  216. C
  217. DO 180 ICOMP=1,N2
  218. C
  219. NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
  220. TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
  221. C
  222. MELVA1=MCHAM1.IELVAL(ICOMP)
  223. SEGACT MELVA1
  224. C
  225. C RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
  226. C
  227. N1PTE1=MELVA1.VELCHE(/1)
  228. N1EL1 =MELVA1.VELCHE(/2)
  229.  
  230. N1PTEL=NBN2
  231. N1EL =NEL
  232. C
  233. N2PTEL=0
  234. N2EL=0
  235.  
  236. SEGINI MELVAL
  237. IELVAL(ICOMP)=MELVAL
  238. C
  239. C TRAITEMENT IMMEDIAT SI CHAMP ORIGINEL CONSTANT
  240. C
  241. IF(N1PTE1.EQ.1) THEN
  242. DO 4120 IEL=1,N1EL
  243. DO 4120 INO=1,NBN2
  244. VELCHE(INO,IEL)=MELVA1.VELCHE(1,IEL)
  245. 4120 CONTINUE
  246. C
  247. ELSE
  248. DO 3120 IEL=1,NEL
  249. DO 3121 IGAU=1,NBN1
  250. VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
  251. 3121 CONTINUE
  252. C
  253. C LE CHAMELEM 1 EST AUX NOEUDS ET ON VEUT CHANGER DE SPG
  254. C
  255. IF(IPLAC1.EQ.1) THEN
  256. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  257. CALL QUEDIM(MELGEO,KERRE)
  258. CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
  259. > SWORK,1,KERRE)
  260. IF(KERRE.NE.0) THEN
  261. IRET=KERRE
  262. SEGDES MELVA1,MELEME,IMODEL,MCHAM1
  263. SEGSUP SWORK,MCHAML,MELVAL
  264. GO TO 665
  265. ENDIF
  266. C
  267. DO 3122 IGAU=1,NBN2
  268. VELCHE(IGAU,IEL)=VAL2(IGAU)
  269. 3122 CONTINUE
  270. C
  271. C PASSAGE D'UN SPG QUELCONQUE VERS UN CHAMELEM AUX NOEUDS
  272. C
  273. ELSEIF(IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN
  274. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  275. CALL QUEDIM(MELGEO,KERRE)
  276. CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
  277. > SWORK,2,KERRE)
  278. IF(KERRE.NE.0) THEN
  279. IRET=KERRE
  280. SEGDES MELVA1,MELEME,IMODEL,MCHAM1
  281. SEGSUP SWORK,MCHAML,MELVAL
  282. GO TO 665
  283. ENDIF
  284. C
  285. DO 3123 IGAU=1,NBN2
  286. VELCHE(IGAU,IEL)=VAL2(IGAU)
  287. 3123 CONTINUE
  288. ENDIF
  289. 3120 CONTINUE
  290. C NTEL=NTEL+NEL
  291. ENDIF
  292. SEGDES MELVAL,MELVA1
  293. 180 CONTINUE
  294. SEGSUP SWORK
  295. SEGDES MCHAML,MCHAM1,IMODEL,IPT1
  296. C
  297. IF(INFO.ne.0)SEGSUP INFO
  298. IF (MINTE.NE.0) SEGDES MINTE
  299. IF (MINTE1.NE.0) SEGDES MINTE1
  300. IF (INFO1.NE.0) SEGSUP INFO1
  301. IF (NSOUS.NE.1) SEGDES MELEME
  302.  
  303. 100 CONTINUE
  304. 665 CONTINUE
  305. SEGDES MCHELM,MCHEL1
  306. SEGDES MMODEL
  307. CONTINUE
  308. RETURN
  309. END
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  

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