Télécharger varica.eso

Retour à la liste

Numérotation des lignes :

  1. C VARICA SOURCE CB215821 18/09/11 21:15:24 9913
  2.  
  3. *____________________________________________________________________
  4. *
  5. * Calcul d'un champ variable appele par VARI
  6. *
  7. * ENTREES :
  8. * ---------
  9. *
  10. * IPOI1 Pointeur sur un MCHAML ou un CHPOINT
  11. * IPOI2 Pointeur sur un EVOLUTIO
  12. * IPMODL Pointeur sur un MMODEL
  13. * MICHE = 1 si on a lu un CHPOINT
  14. * JEMIL = 1 A 5 selon le support choisi
  15. *
  16. * SORTIE :
  17. * --------
  18. *
  19. * IRET Pointeur sur le MCHAML resultat
  20. * =0 si operation impossible
  21. *
  22. * Passage aux nouveaux CHAMELEMs par JM CAMPENON LE 05/91
  23. *
  24. *____________________________________________________________________
  25.  
  26. SUBROUTINE VARICA(IPOI1,IPOI2,IPMODL,IRET,MICHE,JEMIL)
  27.  
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC CCOPTIO
  32.  
  33. -INC SMCHAML
  34. -INC SMCHPOI
  35. -INC SMMODEL
  36. -INC SMEVOLL
  37. -INC SMLREEL
  38. -INC SMELEME
  39. -INC SMINTE
  40. -INC SMCOORD
  41. *
  42. SEGMENT SWORK
  43. REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
  44. REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
  45. ENDSEGMENT
  46. *
  47. SEGMENT INFO
  48. INTEGER INFELL(JG)
  49. ENDSEGMENT
  50. *
  51. CHARACTER*4 MOTREF,MOTABS
  52. *
  53. IRET = 0
  54. IPOIN1= 0
  55. *
  56. * On recupere l'objet evolution
  57. *
  58. MEVOLL = IPOI2
  59. SEGACT,MEVOLL
  60. KEVOLL = mevoll.IEVOLL(1)
  61. SEGDES,MEVOLL
  62. SEGACT,KEVOLL
  63. IF (kevoll.TYPX .NE. 'LISTREEL' .OR.
  64. & kevoll.TYPY .NE. 'LISTREEL') THEN
  65. SEGDES,KEVOLL
  66. MOTERR(1:8) = 'LISTREEL'
  67. CALL ERREUR(37)
  68. RETURN
  69. ENDIF
  70. MLREE1 = kevoll.IPROGX
  71. MLREE2 = kevoll.IPROGY
  72. MOTABS = kevoll.NOMEVX(1:4)
  73. SEGDES,KEVOLL
  74. *
  75. SEGACT,MLREE1,MLREE2
  76. NBPOIX = MLREE1.PROG(/1)
  77. NBPOIY = MLREE2.PROG(/1)
  78. * Petites verifications sur le contenu de l'evolution
  79. IF (NBPOIX.NE.NBPOIY) THEN
  80. CALL ERREUR(577)
  81. GOTO 9900
  82. ENDIF
  83. JORDO = 0
  84. CALL VARIFV(MLREE1.PROG,NBPOIX, JORDO)
  85. IF (JORDO.EQ.0) THEN
  86. CALL ERREUR(872)
  87. GOTO 9900
  88. ENDIF
  89. *
  90. IPOIC = IPOI1
  91. IF (MICHE.EQ.0) GO TO 231
  92. *
  93. * Traitement du CHPOINT - Recherche du nombre de composantes
  94. *
  95. MOTREF = MOTABS
  96.  
  97. MCHPO1 = IPOIC
  98. SEGACT,MCHPO1
  99. NSOUP1 = MCHPO1.IPCHP(/1)
  100. *
  101. DO 329 IA = 1, NSOUP1
  102. MSOUP1 = MCHPO1.IPCHP(IA)
  103. SEGACT,MSOUP1
  104. NC1 = MSOUP1.NOCOMP(/2)
  105. IF (NC1.EQ.1) GO TO 321
  106. *
  107. 325 CONTINUE
  108. * SEGDES MSOUP1
  109. GOTO 320
  110. *
  111. 321 CONTINUE
  112. IF (IA.EQ.1) THEN
  113. MOTREF = MSOUP1.NOCOMP(1)
  114. GOTO 330
  115. ENDIF
  116. *
  117. IF (MOTREF.NE.MSOUP1.NOCOMP(1)) GOTO 325
  118. *
  119. 330 CONTINUE
  120. * SEGDES,MSOUP1
  121. *
  122. 329 CONTINUE
  123. *
  124. 320 CONTINUE
  125. IF (MOTREF.EQ.MOTABS) THEN
  126. IVID = 0
  127. CALL EXCOPP(IPOI1,MOTABS,NIFOUR,IPOI11,'SCAL',NIFOUR,IVID)
  128. IF (IERR.NE.0) GOTO 9900
  129. ELSE
  130. * SEGDES,MCHPO1
  131. IVID = 1
  132. IPOI11 = IPOIC
  133. ENDIF
  134. *
  135. * On convertit le CHPOINT en MCHAML
  136. *
  137. CALL CHAME1(0,IPMODL,IPOI11,' ',IPOIC,JEMIL)
  138. IF (IVID.EQ.0) CALL DTCHPO(IPOI11)
  139. IF (IERR.NE.0) GOTO 9900
  140. *
  141. * Poursuite du traitement pour un MCHAML
  142. *
  143. 231 CONTINUE
  144. *
  145. MCHEL1 = IPOIC
  146. SEGACT,MCHEL1
  147. NINF = MCHEL1.INFCHE(/2)
  148. *
  149. * Activation du modele :
  150. *
  151. MMODEL = IPMODL
  152. SEGACT,MMODEL
  153. NSOUS = mmodel.KMODEL(/1)
  154. DO ISOUS = 1, NSOUS
  155. IMODEL = mmodel.KMODEL(ISOUS)
  156. SEGACT,IMODEL
  157. ENDDO
  158. *
  159. * Creation du MCHAML
  160. *
  161. N1 = NSOUS
  162. N3 = 6
  163. L1 = 8
  164. SEGINI,MCHELM
  165. mchelm.IFOCHE = IFOUR
  166. mchelm.TITCHE = 'SCALAIRE'
  167. *
  168. * Boucle sur les sous zone du MCHAML
  169. *
  170. DO 100 ISOUS = 1, NSOUS
  171. *
  172. * Mise en concordance des pointeurs de maillage
  173. *
  174. MELEME = MCHEL1.IMACHE(ISOUS)
  175. DO 150 IO = 1, NSOUS
  176. imodel = mmodel.KMODEL(IO)
  177. IF (imodel.IMAMOD.EQ.MELEME .AND.
  178. & imodel.CONMOD.EQ.MCHEL1.CONCHE(ISOUS)) GOTO 160
  179. 150 CONTINUE
  180. CALL ERREUR(472)
  181. GOTO 9910
  182. *
  183. 160 CONTINUE
  184. *
  185. * Recherche de la composante
  186. *
  187. MCHAM1 = MCHEL1.ICHAML(ISOUS)
  188. SEGACT,MCHAM1
  189. *
  190. * Recherche du nom MOTABS
  191. * pour les champ a une composante pas de verif. de MOTABS
  192. *
  193. ncomp1 = MCHAM1.NOMCHE(/2)
  194. IF (ncomp1.EQ.1) THEN
  195. IPLAC = 1
  196. ELSE
  197. IPLAC = 0
  198. CALL PLACE (MCHAM1.NOMCHE,ncomp1,IPLAC,MOTABS)
  199. *
  200. * On a pas trouve la composante
  201. *
  202. IF (IPLAC.EQ.0) THEN
  203. MOTERR(1:8) = MOTABS
  204. CALL ERREUR(243)
  205. GOTO 9920
  206. ENDIF
  207. ENDIF
  208. *
  209. IF (MCHAM1.TYPCHE(IPLAC).NE.'REAL*8') THEN
  210. MOTERR(1:4) = 'VARI'
  211. MOTERR(5:8) = MCHAM1.NOMCHE(IPLAC)
  212. CALL ERREUR(335)
  213. GOTO 9920
  214. ENDIF
  215. *
  216. * Information sur l'element fini
  217. *
  218. MELE = imodel.NEFMOD
  219. *
  220. * On recupere le nombre de points support NBPGA1 pour l'ancien ch
  221. *
  222. MINTE1 = 0
  223. IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
  224. *
  225. * La sous zone est aux noeuds
  226. *
  227. if (infmod(/1).lt.3) then
  228. IPTR1 = 0
  229. CALL ELQUOI(MELE,0,1,IPTR1,IMODEL)
  230. IF (IERR.NE.0) GOTO 9920
  231. info = IPTR1
  232. MINTE1 = info.INFELL(11)
  233. segsup info
  234. else
  235. MINTE1 = imodel.INFMOD(3)
  236. endif
  237. ELSE
  238. MINTE1 = MCHEL1.INFCHE(ISOUS,4)
  239. ENDIF
  240. SEGACT,MINTE1
  241. NBPGA1 = MINTE1.SHPTOT(/3)
  242. *
  243. * On recupere le nombre de points support NBPGAU du nouveau champ
  244. *
  245. MINTE = 0
  246. if (infmod(/1).lt.2+jemil)then
  247. IPTR1 = 0
  248. CALL ELQUOI(MELE,0,JEMIL,IPTR1,IMODEL)
  249. IF (IERR.NE.0) GOTO 9930
  250. info = IPTR1
  251. MINTE = info.INFELL(11)
  252. MELGEO = info.INFELL(14)
  253. segsup info
  254. else
  255. MINTE = imodel.INFMOD(2+JEMIL)
  256. MELGEO = imodel.INFELE(14)
  257. endif
  258. SEGACT,MINTE
  259. NBPGAU = minte.SHPTOT(/3)
  260. *
  261. ** IMACHE(ISOUS) = MELEME
  262. IMACHE(ISOUS) = MCHEL1.IMACHE(ISOUS)
  263. CONCHE(ISOUS) = MCHEL1.CONCHE(ISOUS)
  264. *
  265. DO 191 IP = 1,NINF
  266. INFCHE(ISOUS,IP) = MCHEL1.INFCHE(ISOUS,IP)
  267. 191 CONTINUE
  268. INFCHE(ISOUS,4) = MINTE
  269. INFCHE(ISOUS,6) = JEMIL
  270. *
  271. * Creation du MCHAML de la sous zone
  272. *
  273. N2 = 1
  274. SEGINI,MCHAML
  275. ICHAML(ISOUS) = MCHAML
  276. mchaml.TYPCHE(1) = 'REAL*8'
  277. mchaml.NOMCHE(1) = 'SCAL'
  278. *
  279. MELVA1 = MCHAM1.IELVAL(IPLAC)
  280. SEGACT,MELVA1
  281. N1PTE1 = MELVA1.VELCHE(/1)
  282. N1EL1 = MELVA1.VELCHE(/2)
  283. *
  284. * taille du nouveau melval/chamelem
  285. *
  286. IF (N1PTE1.EQ.1) THEN
  287. N1PTEL = 1
  288. ELSE
  289. N1PTEL = NBPGAU
  290. ENDIF
  291. N1EL = N1EL1
  292. N2PTEL = 0
  293. N2EL = 0
  294.  
  295. SEGINI,MELVAL
  296. mchaml.IELVAL(1) = MELVAL
  297. *
  298. * Traitement immediat si champ constant
  299. *
  300. IF (N1PTE1.EQ.1) THEN
  301. DO 4120 IEL = 1, N1EL
  302. XTT1 = MELVA1.VELCHE(1,IEL)
  303. CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  304. & XTT1, YTT1)
  305. melval.VELCHE(1,IEL) = YTT1
  306. 4120 CONTINUE
  307. *
  308. ELSE
  309. *
  310. * Meme support (N1PTEL = NBPGAU = NBPGA1 = N1PTE1)
  311. *
  312. IF (MINTE.EQ.MINTE1) THEN
  313. *
  314. DO 3120 IEL = 1, N1EL
  315.  
  316. DO 3121 IGAU = 1, N1PTE1
  317. XTT1 = MELVA1.VELCHE(IGAU,IEL)
  318. CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  319. & XTT1,YTT1)
  320. melval.VELCHE(IGAU,IEL) = YTT1
  321. 3121 CONTINUE
  322. 3120 CONTINUE
  323. *
  324. * Support different
  325. *
  326. ELSE
  327. *
  328. CALL QUEDIM(MELGEO,JDIM)
  329. IF (JDIM.EQ.0) THEN
  330. CALL ERREUR(29)
  331. GOTO 9940
  332. ENDIF
  333. *
  334. N1PAUX = N1PTE1
  335. * Pour les COQ4, le nb de pt de GAUSS vaut 5, mais on
  336. * ne prend que les 4 premiers (le 5ieme sert uniquement
  337. * au cisaillement)
  338. IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX = 4
  339. *
  340. * On recupere le nombre d'elements
  341. *
  342. SEGACT,MELEME
  343. NBNN = meleme.NUM(/1)
  344. NBELEM = meleme.NUM(/2)
  345. *
  346. SEGINI,SWORK
  347.  
  348. DO 3130 IEL = 1, NBELEM
  349.  
  350. DO 3131 IGAU = 1, N1PTE1
  351. XTT1 = MELVA1.VELCHE(IGAU,IEL)
  352. CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  353. & XTT1,YTT1)
  354. VAL1(IGAU) = YTT1
  355. 3131 CONTINUE
  356.  
  357. CALL DOXE(XCOOR,IDIM,NBNN,meleme.NUM,IEL,XE)
  358. KERRE = JDIM
  359. CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,SWORK,
  360. & IPOIN1,KERRE)
  361. IF (KERRE.NE.0) THEN
  362. CALL ERREUR(KERRE)
  363. GOTO 9950
  364. ENDIF
  365. *
  366. DO 3132 IGAU = 1, N1PTEL
  367. melval.VELCHE(IGAU,IEL) = VAL2(IGAU)
  368. 3132 CONTINUE
  369. 3130 CONTINUE
  370.  
  371. SEGSUP,SWORK
  372. SEGDES,MELEME
  373. *
  374. ENDIF
  375. *
  376. ENDIF
  377. SEGDES,MELVAL,MELVA1
  378. SEGDES,MCHAML,MCHAM1
  379. SEGDES,MINTE,MINTE1
  380. *
  381. 100 CONTINUE
  382. *
  383. SEGDES,MCHELM
  384. IRET = MCHELM
  385. GOTO 9901
  386. *
  387. * Erreur dans une sous zone / desactivation et retour
  388. *
  389. 9950 CONTINUE
  390. SEGSUP,SWORK
  391. SEGDES,MELEME
  392. 9940 CONTINUE
  393. SEGDES,MELVA1
  394. SEGSUP,MELVAL,MCHAML
  395. SEGDES,MINTE
  396. 9930 CONTINUE
  397. SEGDES,MINTE1
  398. *
  399. 9920 CONTINUE
  400. SEGDES,MCHAM1
  401. *
  402. 9910 CONTINUE
  403. SEGSUP,MCHELM
  404. IRET = 0
  405.  
  406. * Desactivation (sortie normale ou en cas d'erreur) :
  407. 9901 CONTINUE
  408. IF (MICHE.NE.0) THEN
  409. CALL DTCHAM(IPOIC)
  410. ELSE
  411. SEGDES,MCHEL1
  412. ENDIF
  413. DO ISOUS = 1, NSOUS
  414. IMODEL = mmodel.KMODEL(ISOUS)
  415. SEGDES,IMODEL
  416. ENDDO
  417. SEGDES,MMODEL
  418.  
  419. 9900 CONTINUE
  420. SEGDES,MLREE1,MLREE2
  421. *
  422. RETURN
  423. END
  424.  
  425.  
  426.  
  427.  
  428.  
  429.  

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