Télécharger chaspg.eso

Retour à la liste

Numérotation des lignes :

chaspg
  1. C CHASPG SOURCE CB215821 23/11/06 21:15:03 11781
  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.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC SMMODEL
  37. -INC SMCHAML
  38. -INC SMELEME
  39. -INC SMINTE
  40. -INC SMCOORD
  41.  
  42. PARAMETER (NSPG = 9)
  43. CHARACTER*8 LSPG(NSPG)
  44. C
  45. SEGMENT SWORK
  46. REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
  47. REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
  48. ENDSEGMENT
  49. C
  50. C NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
  51. C N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
  52. C
  53. SEGMENT INFO
  54. INTEGER INFELL(JG)
  55. ENDSEGMENT
  56.  
  57. POINTEUR INFO1.INFO
  58. C
  59. IRET=0
  60.  
  61. LSPG(1)='NOEUD'
  62. LSPG(2)='GRAVITE'
  63. LSPG(3)='RIGIDITE'
  64. LSPG(4)='MASSE'
  65. LSPG(5)='STRESSES'
  66. LSPG(6)='THERMIQU'
  67. LSPG(7)='FACE'
  68. LSPG(8)='P1CENTRE'
  69. LSPG(9)='MSOMMET'
  70.  
  71. C
  72. C ACTIVATION DU MODELE
  73. C
  74. MMODEL=IPMODL
  75. CALL LEKMOD(MMODEL,IDOMA,INEFMD)
  76. NSOUS1=KMODEL(/1)
  77. C
  78. C ACTIVATION DES MCHELM
  79. C
  80. MCHEL1 =IPOI1
  81. NSOUS=MCHEL1.ICHAML(/1)
  82. IF(NSOUS.GT.NSOUS1)THEN
  83. IRET=553
  84. RETURN
  85. ENDIF
  86. N1=NSOUS
  87. L1=MCHEL1.TITCHE(/1)
  88. N3=MCHEL1.INFCHE(/2)
  89. NINF=N3
  90. IF (N3.LT.6) N3=6
  91. SEGINI MCHELM
  92. TITCHE=MCHEL1.TITCHE
  93. IFOCHE=IFOUR
  94. IPOI2=MCHELM
  95. C
  96. C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
  97. C
  98. C NTEL=0
  99. C KK1=0
  100. SEGACT,MCOORD
  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. MELE=NEFMOD
  112.  
  113. IF (IPLAC1.EQ.IPLAC) THEN
  114. IPOI2=IPOI1
  115. RETURN
  116.  
  117. ELSEIF (IPLAC1.EQ.1.AND.IPLAC1.NE.IPLAC) THEN
  118. IF (IPLAC.EQ.2) THEN
  119. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  120. ELSEIF(IPLAC.EQ.8) THEN
  121. IF (MELE.GE.223.AND.MELE.LE.236) THEN
  122. CALL LEKTAB(IDOMA,'MACRO1',IPT1)
  123. ELSE
  124. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  125. ENDIF
  126. CALL LEKTAB(IDOMA,'ELTP1NC',IPT2)
  127. C KK1=1
  128. ELSEIF(IPLAC.EQ.9) THEN
  129. IF (MELE.GE.223.AND.MELE.LE.236) THEN
  130. CALL LEKTAB(IDOMA,'MACRO1',IPT1)
  131. ELSE
  132. CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
  133. ENDIF
  134. ENDIF
  135.  
  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.  
  143. ELSEIF (IPLAC1.NE.1.AND.IPLAC.NE.1) THEN
  144. write(ioimp,*) 'IPLAC1,IPLAC=',IPLAC1,IPLAC
  145. WRITE(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible'
  146. WRITE(6,*)'avec ',LSPG(IPLAC)
  147. WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!'
  148. MOTERR(1:8)='CHASPG '
  149. IRET=1127
  150. RETURN
  151. ENDIF
  152.  
  153. CALL ACTOBJ('MAILLAGE',IPT1,1)
  154. IF(IERR .NE. 0)RETURN
  155.  
  156. IF(NSOUS.NE.1) THEN
  157. MELEME=IPT1.LISOUS(ISOUS)
  158. ELSE
  159. MELEME=IPT1
  160. ENDIF
  161.  
  162. IMACHE(ISOUS)=MELEME
  163. C
  164. C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
  165. C
  166. info=0
  167. if(infmod(/1).lt.2+iplac) then
  168. CALL ELQUOI(MELE,0,IPLAC,IPTR2,IMODEL)
  169. IF ( IERR .NE. 0) GOTO 665
  170. INFO=IPTR2
  171. MELGEO=INFELL(14)
  172. MINTE=INFELL(11)
  173. ELSE
  174. MINTE=infmod(2+iplac)
  175. MELGEO=INFELE(14)
  176. ENDIF
  177.  
  178. INFCHE(ISOUS,4)=MINTE
  179. IF(IPLAC.EQ.1)INFCHE(ISOUS,4)=0
  180. INFCHE(ISOUS,6)=IPLAC
  181. C
  182. C ON RECUPERE LE NOMBRE D ELEMENTS
  183. C
  184. NBNN =NUM(/1)
  185. NEL =NUM(/2)
  186. C WRITE(6,*)'NBNN=',NBNN,'NEL=',NEL
  187. C
  188. C ON RECUPERE LE NOMBRE DE POINTS SUPPORT
  189. C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
  190. C
  191. INFO1=0
  192. IF(MINTE1.EQ.0)THEN
  193. if(infmod(/1).lt.2+iplac1) then
  194. CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
  195. INFO1=IPTR2
  196. MINTE1=INFO1.INFELL(11)
  197. ELSE
  198. minte1=infmod(2+iplac1)
  199. endif
  200. ENDIF
  201. NBN1=MINTE1.SHPTOT(/2)
  202.  
  203. NBN2=SHPTOT(/2)
  204. IF(IPLAC.EQ.2) NBN2=1
  205.  
  206. C WRITE(6,*)'NBN1=',NBN1,'NBN2=',NBN2
  207. SEGINI SWORK
  208. C
  209. C CREATION DU MCHAML
  210. C
  211. MCHAM1=MCHEL1.ICHAML(ISOUS)
  212. N2=MCHAM1.NOMCHE(/2)
  213. SEGINI MCHAML
  214. ICHAML(ISOUS)=MCHAML
  215. C
  216. C BOUCLE SUR LES COMPOSANTES
  217. C
  218. DO 180 ICOMP=1,N2
  219. C
  220. NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
  221. TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
  222. C
  223. MELVA1=MCHAM1.IELVAL(ICOMP)
  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. XFLO=MELVA1.VELCHE(1,IEL)
  244. DO 41201 INO=1,NBN2
  245. VELCHE(INO,IEL)=XFLO
  246. 41201 CONTINUE
  247. 4120 CONTINUE
  248. C
  249. ELSE
  250. DO 3120 IEL=1,NEL
  251. DO 3121 IGAU=1,NBN1
  252. VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
  253. 3121 CONTINUE
  254. C
  255. C LE CHAMELEM 1 EST AUX NOEUDS ET ON VEUT CHANGER DE SPG
  256. C
  257. IF(IPLAC1.EQ.1) THEN
  258. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  259. CALL QUEDIM(MELGEO,KERRE)
  260. CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
  261. > SWORK,1,KERRE)
  262. IF(KERRE.NE.0) THEN
  263. IRET=KERRE
  264. SEGSUP SWORK,MCHAML,MELVAL
  265. GO TO 665
  266. ENDIF
  267. C
  268. DO 3122 IGAU=1,NBN2
  269. VELCHE(IGAU,IEL)=VAL2(IGAU)
  270. 3122 CONTINUE
  271. C
  272. C PASSAGE D'UN SPG QUELCONQUE VERS UN CHAMELEM AUX NOEUDS
  273. C
  274. ELSEIF(IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN
  275. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  276. CALL QUEDIM(MELGEO,KERRE)
  277. CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
  278. > SWORK,2,KERRE)
  279. IF(KERRE.NE.0) THEN
  280. IRET=KERRE
  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. 180 CONTINUE
  293. SEGSUP SWORK
  294. C
  295. IF (INFO .NE.0) SEGSUP INFO
  296. IF (INFO1.NE.0) SEGSUP INFO1
  297.  
  298. 100 CONTINUE
  299. SEGDES,MCOORD
  300.  
  301. 665 CONTINUE
  302. C CONTINUE
  303. RETURN
  304. END
  305.  
  306.  

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