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

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