Télécharger opto2.eso

Retour à la liste

Numérotation des lignes :

opto2
  1. C OPTO2 SOURCE PV 22/07/28 21:15:06 11419
  2. SUBROUTINE OPTO2(TRAVJ,JELEM)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : OPTO2 (anciennement optt2c)
  7. C DESCRIPTION : Une implémentation de l'amélioration d'une topologie
  8. C autour d'un élément. On reprend OPTITOPO pour le corps
  9. C du programme. On reprend l'extraction et la topologie inverse de
  10. C EXTO. Le point crucial sera d'implémenter la modification de la
  11. C topologie : enlever les anciens éléments et mettre les nouveaux.
  12. C
  13. C
  14. C Ici, on est en numérotation locale et on fait l'extraction de la
  15. C topologie proprement dite, son optimisation puis sa mise à jour.
  16. C Les segments transmis sont supposés activés en *MOD
  17. C
  18. C Le point important est de construire la topologie inverse.
  19. C
  20. C Le début est identique à exto2.eso
  21. C
  22. C Repris de optt2b : on raccourcit la subroutine en externalisant
  23. C des opérations en subroutines.
  24. C
  25. C LANGAGE : ESOPE
  26. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  27. C mél : gounand@semt2.smts.cea.fr
  28. C***********************************************************************
  29. C APPELES : EXTO4C, OPTO3
  30. C APPELES (E/S) :
  31. C APPELES (BLAS) :
  32. C APPELES (CALCUL) :
  33. C APPELE PAR : OPTO1
  34. C***********************************************************************
  35. C SYNTAXE GIBIANE :
  36. C ENTREES : JELEM
  37. C ENTREES/SORTIES : JCOORD, JTOPO
  38. C SORTIES :
  39. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  40. C***********************************************************************
  41. C VERSION : v1, 17/10/2017, version initiale
  42. C HISTORIQUE : v1, 17/10/2017, création
  43. C HISTORIQUE :
  44. C HISTORIQUE :
  45. C***********************************************************************
  46. -INC PPARAM
  47. -INC CCOPTIO
  48. -INC TMATOP2
  49. -INC SMLENTI
  50. POINTEUR JNBL.MLENTI
  51. POINTEUR JNNO.MLENTI,KNNO.MLENTI
  52. POINTEUR NEXTO.MLENTI
  53. -INC SMELEME
  54. *
  55. * Le nombre d'éléments de JTOPO et le nombre de points de JCOORD
  56. * vont être variables. Pour ne pas avoir à ajuster ces segments en
  57. * permanence, on va dimensionner plus large, mais du coup, il faut
  58. * aussi maintenir à la main le nombre de noeuds et d'éléments
  59. * courants.
  60. *
  61. * Le nombre d'éléments courants est NVCOU et le nombre d'éléments
  62. * max est NVMAX. Idem pour le nombre de noeuds courants et max :
  63. * NPCOU et NPMAX.
  64. *
  65. * Numerotation locale des éléments JTOPO.NUM(NBNN,NBELEM)
  66. * INTEGER NVCOU,NVMAX
  67. POINTEUR JTOPO.MELEME
  68. *del POINTEUR KTOPO.MELEME
  69. POINTEUR JELEM.MELEME
  70. POINTEUR JELEM1.MELEME
  71. POINTEUR JEXTO.MELEME,KEXTO.MELEME
  72. POINTEUR JTBES.MELEME
  73. -INC SMCOORD
  74. * Numerotation locale (de 1 à NBPTS)
  75. * INTEGER NPCOU,NPMAX
  76. *del POINTEUR JCOORD.MCOORD
  77. POINTEUR KCOORD.MCOORD
  78. -INC TMATOP1
  79. *-INC STOPINV
  80. *-INC SMETRIQ
  81. POINTEUR JCMETR.METRIQ
  82. POINTEUR KCMETR.METRIQ
  83. *-INC STRAVJ
  84. POINTEUR TRAVK.TRAVJ
  85. *-INC STRAVL
  86. -INC SMLMOTS
  87. POINTEUR JNMETR.MLMOTS
  88. POINTEUR KNMETR.MLMOTS
  89. *
  90. POINTEUR TRAVX.TRAVJ
  91. *
  92. *-INC SMLENTX
  93. POINTEUR ICPRX.MLENTX
  94. POINTEUR IDCPX.MLENTX
  95. *-INC SMELEMX
  96. POINTEUR KELEMX.MELEMX
  97. *
  98. logical lchang
  99. *
  100. * Executable statements
  101. *
  102. if (impr.ge.4) WRITE(IOIMP,*) 'Entrée dans opto2.eso'
  103. *
  104. * Initialisation et extension des segments JTOPO et JCOORD
  105. *
  106. IDIMP=IDIM+1
  107.  
  108. JTOPO=TRAVJ.TOPO
  109. *
  110. * Initialisation de la topologie inverse
  111. *
  112. * CALL INTOPI(NVMAX,NPMAX,TOPINV,IMPR)
  113. CALL INTOP2(TRAVJ,IMPR)
  114. IF (IERR.NE.0) RETURN
  115. *
  116. * Remplissage de la topologie inverse avec JTOPO
  117. *
  118. * CALL RETOPI(JTOPO,NVCOU,TOPINV,IMPR)
  119. CALL RETOP2(TRAVJ,IMPR)
  120. IF (IERR.NE.0) RETURN
  121. *
  122. if (.false.) then
  123. TOPINV=TRAVJ.TOPI
  124. call ectopi(TOPINV,1)
  125. call ectopi(TOPINV,2)
  126. endif
  127. *
  128. * Segment de travail pour l'extraction des éléments
  129. *
  130. JG=NVMAX
  131. SEGINI JNBL
  132. TRAVJ.NBL=JNBL
  133. JG=NPMAX-NPINI
  134. SEGINI JNNO
  135. TRAVJ.NNO=JNNO
  136. *
  137. * Extraction de la topologie à optimiser
  138. *
  139. * NELMOY=40
  140. IF (IDIM.EQ.2) THEN
  141. NELMOY=15
  142. NPOMOY=10
  143. ELSEIF (IDIM.EQ.3) THEN
  144. NELMOY=40
  145. NPOMOY=12
  146. * NELMOY=40
  147. * NPOMOY=25
  148. ELSE
  149. write(ioimp,*) 'idim=',idim
  150. goto 9999
  151. ENDIF
  152. *
  153. *!!! A changer plus tard
  154. *
  155. * NVXMAX=0
  156. SEGINI TRAVX
  157. *old if (isgadj.gt.0) write(ioimp,185) 'TRAVJ,TRAVX=',TRAVJ,TRAVX
  158. TRAVX.NVINI=0
  159. TRAVX.NVCOU=0
  160. TRAVX.NVMAX=NELMOY
  161. * TRAVX.NVMAX=0
  162. JG=TRAVX.NVMAX
  163. SEGINI NEXTO
  164. TRAVX.NBL=NEXTO
  165. *
  166.  
  167. NBNN=IDIMP
  168. NBELEM=TRAVX.NVMAX
  169. NBSOUS=0
  170. NBREF=0
  171. SEGINI JEXTO
  172. JEXTO.ITYPEL=JTOPO.ITYPEL
  173. TRAVX.TOPO=JEXTO
  174. * Boucle sur les éléments
  175. * write(ioimp,*) 'opto2 jelem(nno,nbnn=)',jelem.num(/1)
  176. * $ ,jelem.num(/2)
  177. NBNN1=JELEM.NUM(/1)
  178. NBNN=NBNN1
  179. NBELEM=1
  180. NBSOUS=0
  181. NBREF=0
  182. SEGINI JELEM1
  183. JELEM1.ITYPEL=JELEM.ITYPEL
  184.  
  185. * Segment de travail TRAVK pour opto3 numérotation locale à
  186. * l'élément extrait.
  187. SEGINI TRAVK
  188. TRAVK.NVINI=0
  189. TRAVK.NVCOU=0
  190. TRAVK.NVMAX=NELMOY
  191. * Important pour le segment NNO après
  192. TRAVK.NPINI=0
  193. TRAVK.NPCOU=0
  194. TRAVK.NPMAX=NPOMOY
  195. * IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+MAX(10,NPTINI)
  196. *A changer !!! IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+1
  197. * IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+1
  198. * Topologie de TRAVK (KEXTO)
  199. NBELEM=TRAVK.NVMAX
  200. NBNN=IDIMP
  201. NBSOUS=0
  202. NBREF=0
  203. SEGINI,KEXTO
  204. KEXTO.ITYPEL=JEXTO.ITYPEL
  205. TRAVK.TOPO=KEXTO
  206. * Coordonnées de TRAVK (KCOORD)
  207. NBPTS=TRAVK.NPMAX
  208. SEGINI,KCOORD
  209. TRAVK.COORD=KCOORD
  210. JNMETR=TRAVJ.NMETR
  211. IF (JNMETR.NE.0) THEN
  212. SEGINI,KNMETR=JNMETR
  213. TRAVK.NMETR=KNMETR
  214. ENDIF
  215. JCMETR=TRAVJ.CMETR
  216. IF (JCMETR.NE.0) THEN
  217. NNIN=JCMETR.XIN(/1)
  218. NNNOE=TRAVK.NPMAX
  219. SEGINI,KCMETR
  220. TRAVK.CMETR=KCMETR
  221. ENDIF
  222. *
  223. * Segment de travail pour trouver les noeuds du contour ou de
  224. * l'enveloppe pour étoiler dans topv2
  225. *
  226. JG=TRAVK.NPMAX-TRAVK.NPINI
  227. SEGINI KNNO
  228. TRAVK.NNO=KNNO
  229. * Segment de travail TRAVL pour topv2
  230. NNM=JEXTO.NUM(/1)
  231. ITYP=JEXTO.ITYPEL
  232. *del CALL TRLINI(NELMOY,JEXTO.NUM(/1),JEXTO.ITYPEL,TRAVL)
  233. CALL TRLINI(NELMOY,NNM,ITYP,TRAVL)
  234. if (iveri.ge.2) then
  235. call trlver(travl,'opto2 : Apres initialisation TRAVL')
  236. if (ierr.ne.0) return
  237. endif
  238. *
  239. * Segment de travail pour le changement de numérotation dans opto3
  240. *
  241. JGMAX=NPOMOY
  242. SEGINI ICPRX
  243. CALL mtxadj(ICPRX,0,lchang,'opto2 : ICPRX_INI')
  244. if (ierr.ne.0) return
  245. SEGINI IDCPX
  246. CALL mtxadj(IDCPX,0,lchang,'opto2 : IDCPX_INI')
  247. if (ierr.ne.0) return
  248. *
  249. * Segment de travail pour jelem en numérotation très locale dans
  250. * opto3. Ce segment a un élément et peut-être moins de noeuds que JELEM1
  251. *
  252. NNMAX=JELEM.NUM(/1)
  253. NLMAX=1
  254. SEGINI KELEMX
  255. KELEMX.ITYPEX=JELEM.ITYPEL
  256. KELEMX.NLCOU=1
  257.  
  258.  
  259. DO IAPARC=1,JELEM.NUM(/2)
  260. DO IBNN=1,NBNN1
  261. JELEM1.NUM(IBNN,1)=JELEM.NUM(IBNN,IAPARC)
  262. ENDDO
  263. JPARCO=JPARCO+1
  264. IF (IMPR.GE.4) THEN
  265. write(ioimp,*) ' opto2 : Autour de l''element ',iaparc
  266. call ecmai1(jelem1,0)
  267. segact jelem1*mod
  268. ENDIF
  269. *
  270. if (iveri.ge.2) call vetopi(travj,'Avant exto4')
  271. if (ierr.ne.0) return
  272. *
  273. CALL EXTO4c(JELEM1,TRAVJ,
  274. $ TRAVX)
  275. * verif que NBL est bien nettoyé
  276. if (iveri.ge.2) call vetopi(travj,'Apres exto4')
  277. if (ierr.ne.0) return
  278. *tst write(ioimp,*) 'Elements de la topologie extraits :'
  279. *tst write(ioimp,187) (nexto(I),I=1,travx.nvcou)
  280.  
  281.  
  282. * Mise à jour de jexto
  283. nexto=travx.nbl
  284. jexto=travx.topo
  285. do iel=1,travx.nvcou
  286. do ino=1,IDIMP
  287. JEXTO.NUM(ino,iel)=JTOPO.NUM(INO,nexto.lect(iel))
  288. enddo
  289. enddo
  290. *
  291. * Optimisation de la topologie extraite
  292. *
  293. IF (IMPR.GE.4) THEN
  294. write(ioimp,*) 'opto2.eso : on a extrait la topologie : '
  295. call ecmai1(jexto,0)
  296. segact jexto
  297. ENDIF
  298. *
  299. * Init
  300.  
  301. CALL OPTO3(TRAVJ,TRAVX,JELEM1,TRAVK,TRAVL,ICPRX,IDCPX,
  302. $ KELEMX,
  303. $ JTBES,JCAND)
  304. IF (IERR.NE.0) RETURN
  305. if (iveri.ge.2) call vetopi(travj,'Apres opto3')
  306. IF (IERR.NE.0) RETURN
  307.  
  308. JEXPLO=JEXPLO+ABS(JCAND)
  309. IF (IMPR.GE.4) THEN
  310. IF (JEXTO.EQ.JTBES) THEN
  311. WRITE(IOIMP,*) 'Pas damelioration JTBES=',JTBES
  312. ELSE
  313. WRITE(IOIMP,*) 'Topologie amelioree JTBES=',JTBES
  314. CALL ECMAI1(JTBES,0)
  315. segact jtbes
  316. ENDIF
  317. ENDIF
  318. *
  319. * Si la topologie locale a été améliorée, on change la topologie
  320. * globale en conséquence
  321. *
  322. IF (JEXTO.NE.JTBES) THEN
  323. JCHANG=JCHANG+1
  324. * CALL TOPDIF(TRAVJ,TRAVX)
  325. CALL TOPDI2(TRAVJ,TRAVX)
  326. if (ierr.ne.0) return
  327. if (iveri.ge.2) call vetopi(travj,'Apres DIFF')
  328. if (ierr.ne.0) return
  329. *
  330. * On ajoute les éléments de JTBES dans JTOPO
  331. *
  332. CALL TOPFUS(TRAVJ,JTBES)
  333. if (ierr.ne.0) return
  334. if (iveri.ge.2) call vetopi(travj,'Apres ET')
  335. if (ierr.ne.0) return
  336. ENDIF
  337. *
  338. * Nettoyage de NEXTO et JEXTO (normalement inutile mais utilisé pour
  339. * vetopi)
  340. *
  341. if (iveri.ge.1) then
  342. nexto=travx.nbl
  343. jexto=travx.topo
  344. do iel=1,travx.nvcou
  345. do ino=1,IDIMP
  346. JEXTO.NUM(ino,iel)=0
  347. nexto.lect(iel)=0
  348. enddo
  349. enddo
  350. travx.nvcou=0
  351. endif
  352.  
  353. * Fin boucle sur les éléments
  354. ENDDO
  355. *
  356. * Il faut appeler le nettoyage avant de sortir
  357. *
  358. SEGSUP KELEMX
  359. SEGSUP ICPRX
  360. SEGSUP IDCPX
  361. CALL TRLSUP(TRAVL)
  362. * SEGSUP IPBTL
  363. CALL TOPSUP(TRAVK)
  364. *tst topinv=travj.topi
  365. *tst write(ioimp,*) 'TOPINV Avant nettoyage elem TOPINV'
  366. *tst call ectopi(topinv,1)
  367. *tst call ectopi(topinv,2)
  368. segsup jelem1
  369. if (jtbes.ne.travx.topo) segsup jtbes
  370. call topsup(travx)
  371.  
  372. * Nettoyage des éléments vides
  373. * impr=8
  374. call topclv(travj,lchang)
  375. if (ierr.ne.0) return
  376. if (iveri.ge.2.and.lchang) call vetopi(travj
  377. $ ,'Apres nettoyage elem')
  378. if (ierr.ne.0) return
  379. *
  380. * Nettoyage des noeuds non référencés dans la topologie mais
  381. * seulement ceux ajoutés par nous, pas les autres !
  382. *
  383. call topclp(travj,lchang)
  384. * verif
  385. if (iveri.ge.2.and.lchang) call vetopi(travj
  386. $ ,'Apres nettoyage noeuds')
  387. if (ierr.ne.0) return
  388.  
  389. *
  390. * Normal termination
  391. *
  392. RETURN
  393. *
  394. * Format handling
  395. *
  396. 185 FORMAT (5X,A32,6I8)
  397. 186 FORMAT ('Segment ',A6,' ',A6,' ajusté de ',I6,' à ',I6)
  398. 187 FORMAT (5X,10I8)
  399. 188 FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
  400. 189 FORMAT ('Le noeud ',I2,'/',I2,' de IELEM de numero',I6
  401. $ ,' a le plus petit nb de voisins :',I3)
  402. *
  403. * Error handling
  404. *
  405. 9999 CONTINUE
  406. MOTERR(1:8)='OPTO2 '
  407. * 349 2
  408. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  409. CALL ERREUR(349)
  410. RETURN
  411. *
  412. * End of subroutine OPTO2
  413. *
  414. END
  415.  
  416.  
  417.  
  418.  

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