Télécharger gradia.eso

Retour à la liste

Numérotation des lignes :

  1. C GRADIA SOURCE CHAT 05/01/13 00:20:39 5004
  2. SUBROUTINE GRADIA(ICEN,ISOMM,IFACEL,IFACEP,IMAIL,ISGLIM,
  3. & ICHELM)
  4. C
  5. C**** Variables de COOPTIO
  6. C
  7. C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  8. C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ
  9. C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES
  10. C & ,IECHO, IIMPI, IOSPI
  11. C & ,IDIM
  12. C & ,MCOORD
  13. C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  14. C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  15. C & ,NORINC,NORVAL,NORIND,NORVAD
  16. C & ,NUCROU, IPSAUV
  17. C
  18. IMPLICIT INTEGER(I-N)
  19. -INC CCOPTIO
  20. -INC SMCHPOI
  21. -INC SMELEME
  22. -INC SMLREEL
  23. -INC SMLENTI
  24. -INC SMLMOTS
  25. C
  26. INTEGER ISGLIM
  27. & ,ICEN,ISOMM,IFACEL,IFACEP,IMAIL,IFACE,IFACE1
  28. & ,ICHELM
  29.  
  30. C
  31. SEGMENT MLELEM
  32. INTEGER INDEX(NBL+1)
  33. INTEGER LESPOI(NBTPOI)
  34. ENDSEGMENT
  35. POINTEUR MLELSB.MLELEM, MLELSC.MLELEM, MLESBC.MLELEM,
  36. & MLESCF.MLELEM,MLEFSC.MLELEM,
  37. & MLRDIS.MLREEL, MLEFC.MLELEM
  38. C
  39. INTEGER N1,N2
  40. SEGMENT MATRIX
  41. REAL*8 MAT(N1,N2)
  42. ENDSEGMENT
  43. POINTEUR MATCOE.MATRIX, MACOE1.MATRIX, MACOE2.MATRIX
  44. C
  45. C
  46. C**** Ordonnement FACE, FACEL, FACEP avec le meme ordre
  47. C
  48. CALL RLEORD(IFACEL,IFACEP,IFACE,IFACE1)
  49. IF(IERR .NE. 0)GOTO 9999
  50. C
  51. C**** test RLEORD
  52. C
  53. C MELEME= IFACEP
  54. C IPT1 = IFACE1
  55. C SEGACT MELEME
  56. C SEGACT IPT1
  57. C NBSOUS=MELEME.LISOUS(/1)
  58. C JG=MAX(1,NBSOUS)
  59. C SEGINI MLENTI
  60. C IF(NBSOUS.EQ.0)THEN
  61. C MLENTI.LECT(1)=IFACEP
  62. C ELSE
  63. C DO I1 = 1, NBSOUS, 1
  64. C MLENTI.LECT(I1)=MELEME.LISOUS(I1)
  65. C ENDDO
  66. C ENDIF
  67. C NBSOUS=JG
  68. C IELEM=0
  69. C DO I1 = 1, NBSOUS, 1
  70. C IPT2=MLENTI.LECT(I1)
  71. C SEGACT IPT2
  72. C NBN=IPT2.NUM(/1)
  73. C NBE=IPT2.NUM(/2)
  74. C DO I2 = 1, NBE, 1
  75. C IELEM=IELEM+1
  76. C NGF=IPT2.NUM(NBN,I2)
  77. C NGF1=IPT1.NUM(2,IELEM)
  78. C write(ioimp,*) ngf, ngf1
  79. C ENDDO
  80. C ENDDO
  81. C
  82. C**** Fin test
  83. C
  84. IFACEL=IFACE1
  85. C
  86. C Ici on crée les MELEME IFACE, IFACEL (à eliminer)!
  87. C
  88. C**** Ls voisins type SOMMETS des sommets sur le bord
  89. C
  90. CALL RLEXVB(IFACEL,IFACEP,ISOMM,MLELSB)
  91. IF(IERR.NE.0) GOTO 9999
  92. C
  93. C**** MLELSB = LISTE SEQUENTIELLE INDEXEE D'ELEMENTS
  94. C
  95. C NBL : NOMBRE D'ELEMENTS
  96. C NBTPOI : NOMBRE TOTAL DE POINTS REFERENCEES
  97. C INDEX(I) : INDICE DU 1ER POINT DU IEME ELEMENT
  98. C DANS LE TABLEAU LESPOI
  99. C LESPOI(INDEX(I) -> INDEX(I+1)-1) : NUMERO DES NOEUDS
  100. C DU IEME ELEMENT
  101. C
  102. C NB: LESPOI contient de numero (globals) de noeuds
  103. C (voir RLEVFA)
  104. C
  105. C**** Test de RLEXVB
  106. C
  107. C SEGACT MLELSB
  108. C MELEME = ISOMM
  109. C SEGACT MELEME
  110. C NBL=MLELSB.INDEX(/1)-1
  111. C NBTPOI=MLELSB.LESPOI(/1)
  112. C IPOI=0
  113. C DO I1 = 1, NBL, 1
  114. C IPOI=IPOI+1
  115. C WRITE(IOIMP,*) I1
  116. C IPOS=MLELSB.INDEX(I1)
  117. C NGV=MLELSB.LESPOI(IPOS)
  118. C WRITE(IOIMP,*) 'NGV = ', NGV
  119. C WRITE(IOIMP,*) ' Position ', IPOS
  120. C NVOIS= MLELSB.INDEX(I1+1) - MLELSB.INDEX(I1) - 1
  121. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  122. C DO I2 = 1, NVOIS, 1
  123. C IPOI=IPOI+1
  124. C NGV1=MLELSB.LESPOI(IPOS+I2)
  125. C WRITE(IOIMP,*) NGV1
  126. C ENDDO
  127. C ENDDO
  128. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  129. C
  130. C***** Fin test
  131. C
  132. C**** Ls voisins type CENTRE des sommets
  133. C
  134. CALL RLEXVC(IMAIL,ICEN,ISOMM,MLELSC)
  135. IF(IERR .NE. 0) GOTO 9999
  136. C
  137. C**** MLELSC = LISTE SEQUENTIELLE INDEXEE D'ELEMENTS
  138. C (avec des numeros globals de noeuds)
  139. C
  140. C**** Test de RLEXVC
  141. C
  142. C SEGACT MLELSC
  143. C MELEME = ISOMM
  144. C SEGACT MELEME
  145. C NBL=MLELSC.INDEX(/1)-1
  146. C NBTPOI=MLELSC.LESPOI(/1)
  147. C IPOI=0
  148. C DO I1 = 1, NBL, 1
  149. C IPOI=IPOI+1
  150. C WRITE(IOIMP,*) I1
  151. C IPOS=MLELSC.INDEX(I1)
  152. C NGV=MLELSC.LESPOI(IPOS)
  153. C WRITE(IOIMP,*) 'NGV = ', NGV
  154. C WRITE(IOIMP,*) ' Position ', IPOS
  155. C NVOIS= MLELSC.INDEX(I1+1) - MLELSC.INDEX(I1) - 1
  156. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  157. C DO I2 = 1, NVOIS, 1
  158. C IPOI=IPOI+1
  159. C NGV1=MLELSC.LESPOI(IPOS+I2)
  160. C WRITE(IOIMP,*) NGV1
  161. C ENDDO
  162. C ENDDO
  163. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  164. C
  165. C***** Fin test
  166. C
  167. C Pour les points de bords on va chercher les centres voisins des
  168. C voisins et on va le mettre en ordre decroissante pas raport a la
  169. C distance
  170. C
  171. C MLESBC = sommet de bord - centres voisins de sommets voisins,
  172. C ordonné apar distance
  173. C MLRDIS = LISTREEL qui contient les distances aux carré
  174. C
  175. C En RLEVB1 on detrui MLELSB (= sommet de bord - sommets voisins)
  176. C
  177. CALL RLEVB1(ISOMM,ICEN,MLELSC,MLELSB,MLESBC,MLRDIS)
  178. IF(IERR.NE.0)GOTO 9999
  179. C
  180. C**** Test de RLEVB1
  181. C
  182. C SEGACT MLRDIS
  183. C SEGACT MLESBC
  184. C MELEME = ISOMM
  185. C SEGACT MELEME
  186. C NBL=MLESBC.INDEX(/1)-1
  187. C NBTPOI=MLESBC.LESPOI(/1)
  188. C IPOI=0
  189. C DO I1 = 1, NBL, 1
  190. C IPOI=IPOI+1
  191. C WRITE(IOIMP,*) I1
  192. C IPOS=MLESBC.INDEX(I1)
  193. C NGV=MLESBC.LESPOI(IPOS)
  194. C WRITE(IOIMP,*) 'NGV = ', NGV
  195. C WRITE(IOIMP,*) ' Position ', IPOS
  196. C NVOIS= MLESBC.INDEX(I1+1) - MLESBC.INDEX(I1) - 1
  197. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  198. C DO I2 = 1, NVOIS, 1
  199. C IPOI=IPOI+1
  200. C NGV1=MLESBC.LESPOI(IPOS+I2)
  201. C WRITE(IOIMP,*) NGV1
  202. C WRITE(IOIMP,*) MLRDIS.PROG(IPOS+I2)
  203. C ENDDO
  204. C ENDDO
  205. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  206. C
  207. C***** Fin test
  208. C
  209. C
  210. C**** On cree: MLESCF : sommet - centres "voisins" (F = final)
  211. C MATCOE : MATIRCE qui contient les coeff pour
  212. C la projection CENTRE -> SOMMET
  213. C
  214. C On detrui MLELSC, MLESBC, MLRDIS
  215. C
  216. CALL RLEXCA(ISGLIM,MLELSC,MLESBC,MLRDIS,MLESCF,MATCOE)
  217. IF(IERR.NE.0) GOTO 9999
  218. C
  219. C**** Test de RLEXCA
  220. C
  221. C SEGACT MLESCF
  222. C SEGACT MATCOE
  223. C MELEME = ISOMM
  224. C SEGACT MELEME
  225. C JG=IDIM+1
  226. C SEGINI MLREE1
  227. C NBL=MLESCF.INDEX(/1)-1
  228. C NBTPOI=MLESCF.LESPOI(/1)
  229. C IPOI=0
  230. C DO I1 = 1, NBL, 1
  231. C IPOI=IPOI+1
  232. C WRITE(IOIMP,*) I1
  233. C IPOS=MLESCF.INDEX(I1)
  234. C NGV=MLESCF.LESPOI(IPOS)
  235. C WRITE(IOIMP,*) 'NGV = ', NGV
  236. C WRITE(IOIMP,*) ' Position ', IPOS
  237. C WRITE(IOIMP,*)
  238. C & 'Coeff(',NGV,')=',(MATCOE.MAT(I3,IPOS),I3=1,IDIM+1)
  239. C DO I3=1,IDIM+1
  240. C MLREE1.PROG(I3)=MATCOE.MAT(I3,IPOS)
  241. C ENDDO
  242. C NVOIS= MLESCF.INDEX(I1+1) - MLESCF.INDEX(I1) - 1
  243. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  244. C DO I2 = 1, NVOIS, 1
  245. C IPOI=IPOI+1
  246. C NGV1=MLESCF.LESPOI(IPOS+I2)
  247. C WRITE(IOIMP,*) NGV1
  248. C WRITE(IOIMP,*)
  249. C & 'Coeff(',NGV1,')=',(MATCOE.MAT(I3,IPOI),I3=1,IDIM+1)
  250. C DO I3=1,IDIM+1
  251. C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MATCOE.MAT(I3,IPOI)
  252. C ENDDO
  253. C ENDDO
  254. C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1)
  255. C ENDDO
  256. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  257. C
  258. C***** Fin test
  259. C
  260. C**** On cree: MLEFSC : centre de face - (sommets - centres) voisins
  261. C MACOE1 : MATRICE qui contient les coeff pour
  262. C la projection CENTRE, SOMMET -> FACE
  263. C
  264. CALL RLECA1(IFACEL,IFACEP,MLEFSC,MACOE1)
  265. IF(IERR.NE.0)GOTO 9999
  266. C
  267. C**** Test de RLECA1
  268. C
  269. C SEGACT MLEFSC
  270. C SEGACT MACOE1
  271. C JG=IDIM+1
  272. C SEGINI MLREE1
  273. C NBL=MLEFSC.INDEX(/1)-1
  274. C NBTPOI=MLEFSC.LESPOI(/1)
  275. C IPOI=0
  276. C DO I1 = 1, NBL, 1
  277. C IPOI=IPOI+1
  278. C WRITE(IOIMP,*) I1
  279. C IPOS=MLEFSC.INDEX(I1)
  280. C NGV=MLEFSC.LESPOI(IPOS)
  281. C WRITE(IOIMP,*) 'NGF = ', NGV
  282. C WRITE(IOIMP,*) ' Position ', IPOS
  283. C WRITE(IOIMP,*)
  284. C & 'Coeff(',NGV,')=',(MACOE1.MAT(I3,IPOS),I3=1,IDIM+1)
  285. C DO I3=1,IDIM+1
  286. C MLREE1.PROG(I3)=MACOE1.MAT(I3,IPOS)
  287. C ENDDO
  288. C NVOIS= MLEFSC.INDEX(I1+1) - MLEFSC.INDEX(I1) - 1
  289. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  290. C DO I2 = 1, NVOIS, 1
  291. C IPOI=IPOI+1
  292. C NGV1=MLEFSC.LESPOI(IPOS+I2)
  293. C WRITE(IOIMP,*) NGV1
  294. C WRITE(IOIMP,*)
  295. C & 'Coeff(',NGV1,')=',(MACOE1.MAT(I3,IPOI),I3=1,IDIM+1)
  296. C DO I3=1,IDIM+1
  297. C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE1.MAT(I3,IPOI)
  298. C ENDDO
  299. C ENDDO
  300. C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1)
  301. C ENDDO
  302. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  303. C
  304. C***** Fin test
  305. C
  306. C
  307. C**** RLEXFI
  308. C
  309. C Creation du MLELEM qui contient
  310. C Points faces - voisins centres
  311. C
  312. CALL RLEXFI(MLESCF,MATCOE,MLEFSC,MACOE1,MLEFC,MACOE2)
  313. C
  314. C**** Test de RLEXFI
  315. C
  316. C SEGACT MLEFC
  317. C SEGACT MACOE2
  318. C JG=IDIM
  319. C SEGINI MLREE1
  320. C MELEME = ISOMM
  321. C SEGACT MELEME
  322. C NBL=MLEFC.INDEX(/1)-1
  323. C NBTPOI=MLEFC.LESPOI(/1)
  324. C IPOI=0
  325. C DO I1 = 1, NBL, 1
  326. C IPOI=IPOI+1
  327. C WRITE(IOIMP,*) I1
  328. C IPOS=MLEFC.INDEX(I1)
  329. C NGV=MLEFC.LESPOI(IPOS)
  330. C WRITE(IOIMP,*) 'NGV = ', NGV
  331. C WRITE(IOIMP,*) ' Position ', IPOS
  332. C WRITE(IOIMP,*)
  333. C & 'Coeff(',NGV,')=',(MACOE2.MAT(I3,IPOS),I3=1,IDIM)
  334. C DO I3=1,IDIM
  335. C MLREE1.PROG(I3)=MACOE2.MAT(I3,IPOS)
  336. C ENDDO
  337. C NVOIS= MLEFC.INDEX(I1+1) - MLEFC.INDEX(I1) - 1
  338. C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
  339. C DO I2 = 1, NVOIS, 1
  340. C IPOI=IPOI+1
  341. C NGV1=MLEFC.LESPOI(IPOS+I2)
  342. C WRITE(IOIMP,*) NGV1
  343. C WRITE(IOIMP,*)
  344. C & 'Coeff(',NGV1,')=',(MACOE2.MAT(I3,IPOI),I3=1,IDIM)
  345. C DO I3=1,IDIM
  346. C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE2.MAT(I3,IPOI)
  347. C ENDDO
  348. C ENDDO
  349. C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM)
  350. C ENDDO
  351. C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
  352. C
  353. C***** Fin test
  354. C
  355. C
  356. C**** Creation de MCHAML
  357. C MLEFC, MACOE2 -> MCHAML
  358. C
  359. CALL RLEXCO(MLEFC,MACOE2,ICHELM)
  360. IF(IERR.NE.0)GOTO 9999
  361. C
  362. C**** On detrui le FACEL et IFAC ici crée
  363. C
  364. MELEME=IFACEL
  365. SEGSUP MELEME
  366. MELEME=IFACE
  367. SEGSUP MELEME
  368. C
  369. 9999 CONTINUE
  370. RETURN
  371. END
  372.  
  373.  
  374.  
  375.  
  376.  
  377.  
  378.  
  379.  
  380.  

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