Télécharger calnu4.eso

Retour à la liste

Numérotation des lignes :

  1. C CALNU4 SOURCE PV 16/11/17 21:58:19 9180
  2. SUBROUTINE CALNU4(LITYP,LINIV,KMINCT,PMTOT,
  3. $ IRENU,
  4. $ NEWNUM,
  5. $ IMPR,IRET)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. IMPLICIT INTEGER (I-N)
  8. C***********************************************************************
  9. C NOM : CALNU4
  10. C PROJET : Noyau linéaire NLIN
  11. C DESCRIPTION : Calcul d'une renumérotation avec minimisation d'un
  12. C profil PUIS placement des inconnues suivant l'ordre
  13. C donné par LIORD
  14. C Dans calnum, on effectuait les choses suivantes :
  15. C - minimisation du profil sur les ddl sans les ML.
  16. C - insertion des ML dans la nouvelle numérotation
  17. C Maintenant, on essaie la chose suivante :
  18. C - minimisation du profil sur les ddl AVEC les ML.;
  19. C - retrait des ML de la numérotation ;
  20. C - réinsertion des ML pour les placer après les ddl non
  21. C ML auxquels ils sont liés.
  22. C
  23. C IRENU=1 'RIEN' : pas de renumérotation
  24. C 2 'SLOA' : algorithme de chez Sloan
  25. C 3 'GIPR' : Gibbs-King (profile reduction)
  26. C 4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
  27. C
  28. C LANGAGE : ESOPE
  29. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  30. C mél : gounand@semt2.smts.cea.fr
  31. C***********************************************************************
  32. C APPELES : RENUME
  33. C APPELES (UTIL.) : ISETI, ISHELI, RSETXI
  34. C APPELE PAR : PRASEM
  35. C***********************************************************************
  36. C ENTREES : KMINCT, PMTOT, IRENU
  37. C SORTIES : NEWNUM
  38. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  39. C***********************************************************************
  40. C VERSION : v1, 01/04/04, version initiale
  41. C HISTORIQUE : v1, 01/04/04, création
  42. C HISTORIQUE : voir note * SG 10/06/2015
  43. C HISTORIQUE :
  44. C***********************************************************************
  45. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  46. C en cas de modification de ce sous-programme afin de faciliter
  47. C la maintenance !
  48. C***********************************************************************
  49. -INC CCOPTIO
  50. POINTEUR KMINCT.MINC
  51. POINTEUR PMTOT.PMORS
  52. -INC SMLENTI
  53. INTEGER JG
  54. POINTEUR LITYP.MLENTI
  55. POINTEUR LINIV.MLENTI
  56. POINTEUR DDLINC.MLENTI
  57. *inu POINTEUR DDLPT.MLENTI
  58. POINTEUR NEWNUM.MLENTI
  59. POINTEUR KRDDL.MLENTI
  60. POINTEUR NNUTOT.MLENTI
  61. POINTEUR PRMDDL.MLENTI
  62. SEGMENT LML
  63. POINTEUR ML(NINC).MLENTI
  64. ENDSEGMENT
  65. POINTEUR DDLDIM.MLENTI
  66. POINTEUR ITTDDL.MLENTI
  67. POINTEUR INUDDL.MLENTI
  68. POINTEUR LDD.LML
  69. POINTEUR LDDI.MLENTI
  70. POINTEUR NNU.LML
  71. POINTEUR NNUI.MLENTI
  72. POINTEUR NNUJ.MLENTI
  73. POINTEUR NNUK.MLENTI
  74. POINTEUR PRM.LML
  75. POINTEUR PRMI.MLENTI
  76. *-INC SMLLOGI
  77. SEGMENT MLLOGI
  78. LOGICAL LOGI(JG)
  79. ENDSEGMENT
  80. POINTEUR DDLOK.MLLOGI
  81. * POINTEUR PTLAG.MLLOGI
  82. POINTEUR DDLLAG.MLLOGI
  83. *
  84. *STAT-INC SMSTAT
  85. *
  86. INTEGER IMPR,IRET
  87. INTEGER IRENU
  88. *
  89. INTEGER ITOTPO,JTTDDL
  90. INTEGER NTOTPO,NTTDDL
  91. LOGICAL LLAG,LRELA
  92. *
  93. * Executable statements
  94. *
  95. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans calnu4'
  96. *
  97. * Construction de DDLINC : c'est un tableau d'entiers tel que :
  98. * DDLINC(jttddl) = ordre du ddl
  99. *
  100. * SEGPRT,KMINCT
  101. * SEGPRT,PMTOT
  102. * SEGPRT,LITYP
  103. * SEGPRT,LINIV
  104. SEGACT KMINCT
  105. SEGACT LITYP
  106. SEGACT LINIV
  107. NINC=KMINCT.LISINC(/2)
  108. MAXNIV=0
  109. DO IINC=1,NINC
  110. MAXNIV=MAX(MAXNIV,LINIV.LECT(IINC))
  111. ENDDO
  112. *
  113. * Construction de DDLINC et DDLPT : sorte de segment réciproque
  114. * de KMINCT
  115. * En fait, DDLPT est inutile pour la suite.
  116. * Construction de DDLLAG : liste des ddl de niveau > 1
  117. *
  118. NTOTPO=KMINCT.NPOS(/1)-1
  119. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  120. JG=NTTDDL
  121. SEGINI DDLINC
  122. *inu JG=NTTDDL
  123. *inu SEGINI DDLPT
  124. JG=NTTDDL
  125. * Initialisé à .FALSE.
  126. SEGINI DDLLAG
  127. LRELA=.FALSE.
  128. DO ITOTPO=1,NTOTPO
  129. DO IINC=1,NINC
  130. IPOS=KMINCT.MPOS(ITOTPO,IINC)
  131. IF (IPOS.NE.0) THEN
  132. JPOS=KMINCT.NPOS(ITOTPO)+IPOS-1
  133. DDLINC.LECT(JPOS)=IINC
  134. *inu DDLPT.LECT(JPOS)=ITOTPO
  135. * Non ! IF (LITYP.LECT(IINC).LE.2) THEN
  136. IF (LINIV.LECT(IINC).GE.2) THEN
  137. DDLLAG.LOGI(JPOS)=.TRUE.
  138. LRELA=.TRUE.
  139. ENDIF
  140. ENDIF
  141. ENDDO
  142. ENDDO
  143. * SEGPRT,DDLINC
  144. *inu SEGPRT,DDLPT
  145. * SEGPRT,DDLLAG
  146. *dbg DO ITTDDL=1,NTTDDL
  147. *dbg CALL DDL2PI(ITTDDL,KMINCT,
  148. *dbg $ IPT,IBI,
  149. *dbg $ IMPR,IRET)
  150. *dbg IF (IRET.NE.0) GOTO 9999
  151. *dbg WRITE(IOIMP,*) 'ddl ',ITTDDL,' = IPT=',IPT,
  152. *dbg $ ' inconnue ',KMINCT.LISINC(IBI)
  153. *dbg ENDDO
  154. *inu SEGSUP DDLPT
  155. *
  156. * Construction des tableaux d'entiers suivants :
  157. * LDD.IINC(1..NTTINC) liste des ddl de l'inconnue iinc
  158. * DDLINC(JTTDDL)=IINC : numéro de l'inconnue du ddl de numéro jttddl
  159. * KRDDL(JTTDDL)=ITTINC avec LDD.IINC(ITTINC)
  160. *
  161. SEGINI LDD
  162. JG=NINC
  163. SEGINI DDLDIM
  164. DO IINC=1,NINC
  165. JG=0
  166. SEGINI LDDI
  167. LDD.ML(IINC)=LDDI
  168. ENDDO
  169. JG=NTTDDL
  170. SEGINI KRDDL
  171. DO JTTDDL=1,NTTDDL
  172. IINC=DDLINC.LECT(JTTDDL)
  173. LDDI=LDD.ML(IINC)
  174. ITTINC=DDLDIM.LECT(IINC)+1
  175. LDDI.LECT(**)=JTTDDL
  176. KRDDL.LECT(JTTDDL)=ITTINC
  177. DDLDIM.LECT(IINC)=ITTINC
  178. ENDDO
  179. C SEGPRT,DDLDIM
  180. C SEGPRT,LDD
  181. C DO IINC=1,NINC
  182. C LDDI=LDD.ML(IINC)
  183. C SEGPRT,LDDI
  184. C ENDDO
  185. C SEGPRT,KRDDL
  186. *STAT CALL PRMSTA(' Préparation renume divers',MSTAT,IMPR)
  187. *
  188. * Obtention de la nouvelle numérotation des ddl
  189. * In RENUME : SEGINI NNUTOT
  190. * In RENUME : SEGDES NNUTOT
  191. CALL RENUME(PMTOT,IRENU,NNUTOT,IMPR,IRET)
  192. IF (IRET.NE.0) GOTO 9999
  193. C SEGPRT,NNUTOT
  194. *STAT CALL PRMSTA(' Après renume',MSTAT,IMPR)
  195. *
  196. * Construction des NNUs pour les points qui ne sont pas dans
  197. * DDLLAG
  198. *
  199. SEGACT,NNUTOT
  200. * NINC=NINC
  201. SEGINI NNU
  202. DO IINC=1,NINC
  203. JG=DDLDIM.LECT(IINC)
  204. SEGINI NNUI
  205. NNU.ML(IINC)=NNUI
  206. ENDDO
  207. DO ITOTPO=1,NTOTPO
  208. DO IINC=1,NINC
  209. IPOS=KMINCT.MPOS(ITOTPO,IINC)
  210. IF (IPOS.NE.0) THEN
  211. JPOS=KMINCT.NPOS(ITOTPO)+IPOS-1
  212. * SG 10/06/2015 IF (.NOT.DDLLAG.LOGI(JPOS)) THEN
  213. INNU=NNUTOT.LECT(JPOS)
  214. NNUI=NNU.ML(IINC)
  215. KRNNUI=KRDDL.LECT(JPOS)
  216. NNUI.LECT(KRNNUI)=INNU
  217. * SG 10/06/2015 ENDIF
  218. ENDIF
  219. ENDDO
  220. ENDDO
  221. SEGSUP NNUTOT
  222. * SEGPRT,NNU
  223. * DO IINC=1,NINC
  224. * NNUI=NNU.ML(IINC)
  225. * SEGPRT,NNUI
  226. * ENDDO
  227.  
  228. IF (LRELA) THEN
  229. C
  230. C Obtention des numéros des ddl portant sur des points
  231. C où il n'y a que des multiplicateurs de Lagrange
  232. C le max ou le min des ddl de niveau INIV-1 qui lui sont
  233. C reliés
  234. C
  235. SEGACT PMTOT
  236. DO INIV=2,MAXNIV
  237. DO IINC=1,NINC
  238. JNIV=LINIV.LECT(IINC)
  239. IF (JNIV.EQ.INIV) THEN
  240. JTYP=LITYP.LECT(IINC)
  241. DO ITOTPO=1,NTOTPO
  242. IPOS=KMINCT.MPOS(ITOTPO,IINC)
  243. IF (IPOS.NE.0) THEN
  244. JTTDDL=KMINCT.NPOS(ITOTPO)+IPOS-1
  245. IF (DDLLAG.LOGI(JTTDDL)) THEN
  246. * WRITE(IOIMP,*) 'Lagrange JTTDDL=',JTTDDL
  247. JNNU=0
  248. KSTRT=PMTOT.IA(JTTDDL)
  249. KSTOP=PMTOT.IA(JTTDDL+1)-1
  250. * WRITE(IOIMP,*) 'iniv-1=',INIV-1
  251. * WRITE(IOIMP,*) 'kstrt=',kstrt
  252. * WRITE(IOIMP,*) 'kstop=',kstop
  253. DO KIND=KSTRT,KSTOP
  254. KTTDDL=PMTOT.JA(KIND)
  255. KINC=DDLINC.LECT(KTTDDL)
  256. KNIV=LINIV.LECT(KINC)
  257. * WRITE(IOIMP,*) 'kniv=',KNIV
  258. IF (KNIV.LE.INIV-1) THEN
  259. NNUK=NNU.ML(KINC)
  260. KRNNUK=KRDDL.LECT(KTTDDL)
  261. KNNU=NNUK.LECT(KRNNUK)
  262. * WRITE(IOIMP,*) 'ok knnu=',KNNU
  263. IF (KNNU.EQ.0) THEN
  264. WRITE(IOIMP,*) 'Erreur trop grave'
  265. GOTO 9999
  266. ENDIF
  267. IF (JNNU.EQ.0) THEN
  268. JNNU=KNNU
  269. ELSE
  270. IF (JTYP.EQ.4) THEN
  271. JNNU=MIN(JNNU,KNNU)
  272. *! ELSEIF (JTYP.EQ.3) THEN
  273. ELSEIF (JTYP.EQ.3.OR.JTYP.EQ.2) THEN
  274. JNNU=MAX(JNNU,KNNU)
  275. ELSE
  276. WRITE(IOIMP,*) 'Erreur grave 1.2'
  277. GOTO 9999
  278. ENDIF
  279. ENDIF
  280. ENDIF
  281. ENDDO
  282. IF (JNNU.EQ.0) THEN
  283. * SG 10/06/2015
  284. * Ceci peut ne pas etre une erreur apres elimination des relations,
  285. * il peut y avoir des multiplicateurs qui se retrouvent seuls
  286. * ce qui n'est pas un pb s'ils ont une matrice de stabilisation pour
  287. * eux.
  288. * A ce moment-là, on ne change pas leur position dans le profil
  289. * i.e on ne fait rien
  290. * Ceci etait l'ancien debug...
  291. if (.FALSE.) THEN
  292. WRITE(IOIMP,*) 'INIV=',INIV
  293. WRITE(IOIMP,*) 'IINC=',IINC
  294. WRITE(IOIMP,*) 'JTYP=',JTYP
  295. WRITE(IOIMP,*) 'JTTDDL=',JTTDDL
  296. DO KIND=KSTRT,KSTOP
  297. KTTDDL=PMTOT.JA(KIND)
  298. WRITE(IOIMP,*) 'KTTDDL=',KTTDDL
  299. KINC=DDLINC.LECT(KTTDDL)
  300. KNIV=LINIV.LECT(KINC)
  301. WRITE(IOIMP,*) 'KINC=',KINC
  302. WRITE(IOIMP,*) 'KNIV=',KNIV
  303. ENDDO
  304. WRITE(IOIMP,*) 'Erreur grave 1.5'
  305. GOTO 9999
  306. endif
  307. ELSE
  308. NNUJ=NNU.ML(IINC)
  309. KRNNUJ=KRDDL.LECT(JTTDDL)
  310. NNUJ.LECT(KRNNUJ)=JNNU
  311. ENDIF
  312. ENDIF
  313. ENDIF
  314. ENDDO
  315. ENDIF
  316. ENDDO
  317. ENDDO
  318. SEGDES PMTOT
  319. ENDIF
  320. C SEGPRT,NNU
  321. C DO IINC=1,NINC
  322. C NNUI=NNU.ML(IINC)
  323. C SEGPRT,NNUI
  324. C ENDDO
  325. SEGSUP KRDDL
  326. SEGSUP DDLLAG
  327. SEGSUP DDLINC
  328. SEGDES LINIV
  329. SEGDES LITYP
  330. SEGDES KMINCT
  331. *
  332. * 1 On calcule les permutations qui permettent de trier NNU
  333. * par ordre croissant de nouveau numéro.
  334. *
  335. SEGINI PRM
  336. DO IINC=1,NINC
  337. NTTINC=DDLDIM.LECT(IINC)
  338. JG=NTTINC
  339. SEGINI PRMI
  340. CALL ISETI(PRMI.LECT,NTTINC)
  341. PRM.ML(IINC)=PRMI
  342. NNUI=NNU.ML(IINC)
  343. CALL ISHELI(NTTINC,PRMI.LECT,NTTINC,NNUI.LECT,
  344. $ IMPR,IRET)
  345. IF (IRET.NE.0) GOTO 9999
  346. ENDDO
  347. C SEGPRT,PRM
  348. C DO IORD=1,NORD
  349. C PRMI=PRM.ML(IORD)
  350. C SEGPRT,PRMI
  351. C ENDDO
  352. *
  353. * 3 En "merge"ant les listes précédentes, on obtient
  354. * la permutation réciproque de la nouvelle numérotation
  355. * totale que l'on cherche (si, si !)
  356. *
  357. JG=NTTDDL
  358. SEGINI PRMDDL
  359. JG=NINC
  360. SEGINI ITTDDL
  361. DO IINC=1,NINC
  362. ITTDDL.LECT(IINC)=1
  363. ENDDO
  364. JG=NINC
  365. SEGINI DDLOK
  366. DO IINC=1,NINC
  367. DDLOK.LOGI(IINC)=(ITTDDL.LECT(IINC).LE.DDLDIM.LECT(IINC))
  368. ENDDO
  369. JG=NINC
  370. SEGINI INUDDL
  371. DO IINC=1,NINC
  372. IF (DDLOK.LOGI(IINC)) THEN
  373. NNUI=NNU.ML(IINC)
  374. PRMI=PRM.ML(IINC)
  375. * IITT=ITTDDL.LECT(IORD)
  376. * IPRM=PRM1.LECT(IITT)
  377. * INNU=NNU1.LECT(IPRM)
  378. INUDDL.LECT(IINC)=NNUI.LECT(PRMI.LECT(ITTDDL.LECT(IINC)))
  379. ENDIF
  380. ENDDO
  381. DO JTTDDL=1,NTTDDL
  382. JNUMIN=0
  383. JINC=0
  384. DO IINC=1,NINC
  385. IF (DDLOK.LOGI(IINC)) THEN
  386. IF (JNUMIN.EQ.0) THEN
  387. JNUMIN=INUDDL.LECT(IINC)
  388. JINC=IINC
  389. ELSE
  390. KNUMIN=INUDDL.LECT(IINC)
  391. IF (KNUMIN.LT.JNUMIN) THEN
  392. JNUMIN=KNUMIN
  393. JINC=IINC
  394. ENDIF
  395. ENDIF
  396. ENDIF
  397. ENDDO
  398. IF ((JNUMIN.EQ.0).OR.(JINC.EQ.0)) THEN
  399. WRITE(IOIMP,*) 'Erreur trop grave 2'
  400. GOTO 9999
  401. ENDIF
  402. LDDI=LDD.ML(JINC)
  403. NNUI=NNU.ML(JINC)
  404. PRMI=PRM.ML(JINC)
  405. KTTDDL=ITTDDL.LECT(JINC)
  406. PRMDDL.LECT(JTTDDL)=LDDI.LECT(PRMI.LECT(KTTDDL))
  407. ITTDDL.LECT(JINC)=KTTDDL+1
  408. DDLOK.LOGI(JINC)=(ITTDDL.LECT(JINC).LE.DDLDIM.LECT(JINC))
  409. IF (DDLOK.LOGI(JINC)) THEN
  410. NNUI=NNU.ML(JINC)
  411. PRMI=PRM.ML(JINC)
  412. INUDDL.LECT(JINC)=NNUI.LECT(PRMI.LECT(ITTDDL.LECT(JINC)))
  413. ENDIF
  414. ENDDO
  415. SEGSUP INUDDL
  416. SEGSUP DDLOK
  417. SEGSUP ITTDDL
  418. DO IINC=1,NINC
  419. PRMI=PRM.ML(IINC)
  420. SEGSUP PRMI
  421. ENDDO
  422. SEGSUP PRM
  423. DO IINC=1,NINC
  424. NNUI=NNU.ML(IINC)
  425. SEGSUP NNUI
  426. ENDDO
  427. SEGSUP NNU
  428. SEGSUP DDLDIM
  429. DO IINC=1,NINC
  430. LDDI=LDD.ML(IINC)
  431. SEGSUP LDDI
  432. ENDDO
  433. SEGSUP LDD
  434. * SEGPRT,PRMDDL
  435. *
  436. * D'où la nouvelle numérotation :
  437. *
  438. JG=NTTDDL
  439. SEGINI NEWNUM
  440. CALL RSETXI(NEWNUM.LECT,PRMDDL.LECT,NTTDDL)
  441. SEGDES NEWNUM
  442. SEGSUP PRMDDL
  443. *STAT CALL PRMSTA(' Merge et obtention NEWNUM',MSTAT,IMPR)
  444. * SEGPRT,NEWNUM
  445. * STOP 16
  446. *
  447. * Normal termination
  448. *
  449. IRET=0
  450. RETURN
  451. *
  452. * Format handling
  453. *
  454. *
  455. * Error handling
  456. *
  457. 9999 CONTINUE
  458. IRET=1
  459. WRITE(IOIMP,*) 'An error was detected in subroutine calnu4'
  460. RETURN
  461. *
  462. * End of subroutine CALNU4
  463. *
  464. END
  465.  
  466.  
  467.  
  468.  
  469.  
  470.  
  471.  
  472.  
  473.  
  474.  

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