Télécharger pola1.eso

Retour à la liste

Numérotation des lignes :

  1. C POLA1 SOURCE BP208322 15/06/22 21:21:20 8543
  2. SUBROUTINE POLA1(IPMODL,IPCHE1,IPCHE2,IPCHE3,IMIL)
  3. *---------------------------------------------------------------------
  4. *
  5. * CALCUL DE LA DECOMPOSITION POLAIRE
  6. * (APPELE PAR POLA)
  7. *
  8. * ENTREES:
  9. * --------
  10. *
  11. * IPMODL POINTEUR SUR UN MMODEL
  12. * IPCHE1 POINTEUR SUR UN CHAMELEM DE GRADIENTS
  13. * (TYPE MCHAML)
  14. * IMIL INDICATEUR DEPL OU GEOM SELON QUE LE
  15. * GRADIENT EST CELUI D'UN DEPLACEMENT
  16. * OU D'UNE GEOMETRIE
  17. *
  18. * SORTIES :
  19. * ---------
  20. *
  21. * IPCHE2 POINTEUR SUR UN CHAMELEM R
  22. * IPCHE3 POINTEUR SUR UN CHAMELEM U
  23. *
  24. *---------------------------------------------------------------------
  25. *
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30. -INC SMCHAML
  31. -INC SMMODEL
  32. *
  33. SEGMENT NOTYPE
  34. CHARACTER*16 TYPE(NBTYPE)
  35. ENDSEGMENT
  36. *
  37. SEGMENT MPTVAL
  38. INTEGER IPOS(NS) ,NSOF(NS)
  39. INTEGER IVAL(NCOSOU)
  40. CHARACTER*16 TYVAL(NCOSOU)
  41. ENDSEGMENT
  42. *
  43. PARAMETER ( NINF=3 )
  44. INTEGER INFOS(NINF)
  45. CHARACTER*(NCONCH) CONM
  46. LOGICAL lsupgd
  47. *
  48. DIMENSION F(9),R(9),U(9)
  49.  
  50. NHRM=NIFOUR
  51. *
  52. MCHELM=IPCHE1
  53. SEGACT MCHELM
  54. IF(TITCHE.NE.'GRADIENT') THEN
  55. MOTERR(1:8)='GRADIENT'
  56. CALL ERREUR(145)
  57. GOTO 666
  58. ENDIF
  59. *
  60. * ... VERIFICATION DU LIEU SUPPORT DU MCHAML DE GRADIENT
  61. *
  62. N1=INFCHE(/1)
  63. N3=INFCHE(/2)
  64. IF(N3.LT.6) THEN
  65. ISUP1=1
  66. ELSE
  67. ISUP1=INFCHE(1,6)
  68. DO 1000 ISCHAM=2,N1
  69. IF(INFCHE(ISCHAM,6).NE.ISUP1) THEN
  70. CALL ERREUR(560)
  71. SEGDES,MCHELM
  72. RETURN
  73. ENDIF
  74. 1000 CONTINUE
  75. ENDIF
  76. *
  77. * ... ACTIVATION DU MODELE ...
  78. *
  79. MMODEL=IPMODL
  80. SEGACT MMODEL
  81. NSOUS=KMODEL(/1)
  82.  
  83. C ... Initialisation des deux nouveaux MCHELM - résultats ...
  84. C les MCHAML resultats sont types GRADIENT pour simplifier
  85. C la gestion des noms des composantes
  86. C
  87.  
  88. N1=NSOUS
  89. L1=8
  90. N3=6
  91. *
  92. SEGINI MCHEL1
  93. IPCHE2=MCHEL1
  94. MCHEL1.IFOCHE=IFOUR
  95. MCHEL1.TITCHE='GRADIENT'
  96. *
  97. SEGINI MCHEL2
  98. IPCHE3=MCHEL2
  99. MCHEL2.IFOCHE=IFOUR
  100. MCHEL2.TITCHE='GRADIENT'
  101. *
  102. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  103. *
  104. DO 200 ISOUS=1,NSOUS
  105. *
  106. * ... INITIALISATION ...
  107. *
  108. NCOMP=0
  109. IVACOM = 0
  110. MOCOMP = 0
  111. IVAGR1 = 0
  112. IVAGR2 = 0
  113. IMODEL=KMODEL(ISOUS)
  114. SEGACT IMODEL
  115. *
  116. IPMAIL=IMAMOD
  117. CONM =CONMOD
  118. MELE =NEFMOD
  119. C
  120. C ... COQUE INTEGREE OU PAS ? ...
  121. C
  122. IF(INFMOD(/1).NE.0)THEN
  123. NPINT=INFMOD(1)
  124. ELSE
  125. NPINT=0
  126. ENDIF
  127. IF (NPINT.NE.0)THEN
  128. CALL ERREUR(615)
  129. SEGDES IMODEL,MMODEL
  130. SEGSUP MCHEL1,MCHEL2
  131. GOTO 666
  132. ENDIF
  133. *
  134. * ... INFORMATION SUR L'ELEMENT FINI ...
  135. *
  136. * CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL)
  137. IF (IERR.NE.0) THEN
  138. SEGDES IMODEL,MMODEL
  139. SEGSUP MCHEL1,MCHEL2
  140. GOTO 666
  141. ENDIF
  142. *
  143. * INFO =IPINF
  144. MFR =INFELE(13)
  145. * MINTE =INFELE(11)
  146. minte=infmod(2+isup1)
  147. *
  148. * ... Verfication de compatibilité des MCHAML du point de vue des
  149. * tableaux INFCHE et remplissage du tableau INFOS pour COMCHA ...
  150. *
  151. CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD)
  152. IF (IRTD.EQ.0) THEN
  153. SEGDES IMODEL,MMODEL
  154. SEGSUP MCHEL1,MCHEL2
  155. * SEGSUP INFO
  156. GOTO 666
  157. ENDIF
  158. *
  159. * ... Les attributs de chaque sous-zone ...
  160. *
  161. MCHEL1.INFCHE(ISOUS,1)=0
  162. MCHEL1.INFCHE(ISOUS,2)=0
  163. MCHEL1.INFCHE(ISOUS,3)=NHRM
  164. MCHEL1.INFCHE(ISOUS,4)=MINTE
  165. MCHEL1.INFCHE(ISOUS,5)=0
  166. MCHEL1.INFCHE(ISOUS,6)=ISUP1
  167. MCHEL1.IMACHE(ISOUS)=IPMAIL
  168. MCHEL1.CONCHE(ISOUS)=CONMOD
  169. *
  170. MCHEL2.INFCHE(ISOUS,1)=0
  171. MCHEL2.INFCHE(ISOUS,2)=0
  172. MCHEL2.INFCHE(ISOUS,3)=NHRM
  173. MCHEL2.INFCHE(ISOUS,4)=MINTE
  174. MCHEL2.INFCHE(ISOUS,5)=0
  175. MCHEL2.INFCHE(ISOUS,6)=ISUP1
  176. MCHEL2.IMACHE(ISOUS)=IPMAIL
  177. MCHEL2.CONCHE(ISOUS)=CONMOD
  178. *
  179. * ... RECHERCHE DES NOMS de COMPOSANTES ...
  180. *
  181. if(lnomid(3).ne.0) then
  182. nomid=lnomid(3)
  183. segact nomid
  184. mocomp=nomid
  185. ncomp=lesobl(/2)
  186. nfac=lesfac(/2)
  187. lsupgd=.false.
  188. else
  189. lsupgd=.true.
  190. CALL IDGRAD(MFR,IFOUR,MOCOMP,NCOMP,NFAC)
  191. endif
  192. *
  193. * ... VERIFICATION DE LEUR PRESENCE ...
  194. *
  195. NBTYPE=1
  196. SEGINI NOTYPE
  197. MOTYPE=NOTYPE
  198. TYPE(1)='REAL*8'
  199. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM)
  200. SEGSUP NOTYPE
  201. IF (IERR.NE.0) THEN
  202. IVASC1=0
  203. IVASC2=0
  204. GOTO 9990
  205. ENDIF
  206. *
  207. * ... RECHERCHE DA LA TAILLE DES MELVAL A ALLOUER ...
  208. *
  209. N1PTEL=0
  210. N1EL=0
  211. MPTVAL=IVACOM
  212. DO 110 ICOMP=1,NCOMP
  213. MELVAL=IVAL(ICOMP)
  214. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  215. N1EL =MAX(N1EL ,VELCHE(/2))
  216. 110 CONTINUE
  217. N2PTEL=0
  218. N2EL=0
  219. *
  220. * ... Création et stockage des MCHAML ...
  221. *
  222. N2=NCOMP
  223. SEGINI MCHAM1
  224. MCHEL1.ICHAML(ISOUS)=MCHAM1
  225. SEGINI MCHAM2
  226. MCHEL2.ICHAML(ISOUS)=MCHAM2
  227. *
  228. C ... et des MELVAL de la zone élémentaire ...
  229. C
  230. NS=1
  231. NCOSOU=NCOMP
  232. SEGINI MPTVAL
  233. IVAGR1=MPTVAL
  234. NOMID=MOCOMP
  235. SEGACT NOMID
  236. DO 71 ICOMP=1,NCOMP
  237. MCHAM1.TYPCHE(ICOMP)='REAL*8'
  238. MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  239. SEGINI MELVAL
  240. MCHAM1.IELVAL(ICOMP)=MELVAL
  241. IVAL(ICOMP)=MELVAL
  242. 71 CONTINUE
  243. *
  244. SEGINI MPTVAL
  245. IVAGR2=MPTVAL
  246. NOMID=MOCOMP
  247. SEGACT NOMID
  248. DO 72 ICOMP=1,NCOMP
  249. MCHAM2.TYPCHE(ICOMP)='REAL*8'
  250. MCHAM2.NOMCHE(ICOMP)=LESOBL(ICOMP)
  251. SEGINI MELVAL
  252. MCHAM2.IELVAL(ICOMP)=MELVAL
  253. IVAL(ICOMP)=MELVAL
  254. 72 CONTINUE
  255. *
  256. *
  257. **********************************************************************
  258. * *
  259. * BRANCHEMENT SUIVANT LA DIMENSION *
  260. * *
  261. **********************************************************************
  262. *
  263. LADIM=0
  264. IF(NCOMP.EQ.4) LADIM=2
  265. IF(NCOMP.EQ.9) LADIM=3
  266. IF(LADIM.EQ.0) GO TO 9990
  267. *
  268. * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  269. *
  270.  
  271. DO 31 IB=1,N1EL
  272. DO 31 IGAU=1,N1PTEL
  273. *
  274. * ... Recherche des composantes du gradient
  275. *
  276. MPTVAL=IVACOM
  277. DO 35 ICOMP=1,NCOMP
  278. MELVAL=IVAL(ICOMP)
  279. IGMN=MIN(IGAU,VELCHE(/1))
  280. IBMN=MIN(IB ,VELCHE(/2))
  281. F(ICOMP)=VELCHE(IGMN,IBMN)
  282. 35 CONTINUE
  283. *
  284. * on ajoute 1. si on a lu le mot DEPL
  285. *
  286. IF(IMIL.EQ.1) THEN
  287. IF(LADIM.EQ.2) THEN
  288. F(1)=F(1)+1.D0
  289. F(4)=F(4)+1.D0
  290. ELSE IF(LADIM.EQ.3) THEN
  291. F(1)=F(1)+1.D0
  292. F(5)=F(5)+1.D0
  293. F(9)=F(9)+1.D0
  294. ENDIF
  295. ENDIF
  296. *
  297. * ... Calcul de R et U
  298. *
  299. CALL POLA2(F,R,U,LADIM)
  300. IF(IERR.NE.0) GO TO 9990
  301. *
  302. * ... et leur stockage ...
  303. *
  304. MPTVAL=IVAGR1
  305. DO 36 ICOMP=1,NCOMP
  306. MELVAL=IVAL(ICOMP)
  307. VELCHE(IGAU,IB)=R(ICOMP)
  308. 36 CONTINUE
  309.  
  310. MPTVAL=IVAGR2
  311. DO 37 ICOMP=1,NCOMP
  312. MELVAL=IVAL(ICOMP)
  313. VELCHE(IGAU,IB)=U(ICOMP)
  314. 37 CONTINUE
  315. *
  316. 31 CONTINUE
  317. *
  318. *
  319. * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  320. *
  321. MPTVAL=IVAGR1
  322. DO 76 ICOMP=1,NCOMP
  323. MELVAL=IVAL(ICOMP)
  324. SEGDES MELVAL
  325. 76 CONTINUE
  326.  
  327. MPTVAL=IVAGR2
  328. DO 77 ICOMP=1,NCOMP
  329. MELVAL=IVAL(ICOMP)
  330. SEGDES MELVAL
  331. 77 CONTINUE
  332. *
  333. *
  334. SEGDES MCHAM1,MCHAM2
  335. *
  336. CALL DTMVAL(IVACOM,1)
  337. *
  338. NOMID=MOCOMP
  339. if(lsupgd)SEGSUP NOMID
  340. * SEGSUP INFO
  341. *
  342. SEGDES IMODEL
  343. *
  344. 200 CONTINUE
  345.  
  346. C ... FIN DE LA GRANDE BOUCLE SUR LES ZONES ÉLÉMENTAIRES ...
  347.  
  348.  
  349. SEGDES MCHEL1,MCHEL2
  350. SEGDES MCHELM,MMODEL
  351. RETURN
  352. *
  353. 9990 CONTINUE
  354. *
  355. * ... ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR ...
  356. *
  357. SEGDES IMODEL,MMODEL
  358. SEGSUP MCHEL1,MCHEL2
  359. *
  360.  
  361. CALL DTMVAL(IVACOM,1)
  362. *
  363. IF (IVAGR1.NE.0) THEN
  364. MPTVAL=IVAGR1
  365. DO 86 ICOMP=1,NCOMP
  366. MELVAL=IVAL(ICOMP)
  367. SEGSUP MELVAL
  368. 86 CONTINUE
  369. ENDIF
  370. *
  371. IF (IVAGR2.NE.0) THEN
  372. MPTVAL=IVAGR2
  373. DO 87 ICOMP=1,NCOMP
  374. MELVAL=IVAL(ICOMP)
  375. SEGSUP MELVAL
  376. 87 CONTINUE
  377. ENDIF
  378. *
  379. NOMID =MOCOMP
  380. if(lsupgd)SEGSUP NOMID
  381. *
  382. * SEGSUP INFO
  383. RETURN
  384. *
  385. 666 CONTINUE
  386. SEGDES MCHELM
  387. RETURN
  388. END
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  

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