Télécharger varica.eso

Retour à la liste

Numérotation des lignes :

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

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