Télécharger prasem.eso

Retour à la liste

Numérotation des lignes :

  1. C PRASEM SOURCE PV 20/03/30 21:22:27 10567
  2. SUBROUTINE PRASEM(MATELE,MRENU,MMULAG,METASS,
  3. $ IMPR,IRET)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM : PRASEM
  8. C PROJET : Noyau linéaire NLIN
  9. C DESCRIPTION : On effectue l'assemblage d'un ensemble de matrices
  10. C élémentaires pour faire une matrice Morse.
  11. C
  12. C
  13. C Quelques commentaires sur la numérotation pour le placement des
  14. C multiplicateurs de Lagrange :
  15. C
  16. C * Au niveau des noms d'inconnues :
  17. C 1) Placement juste après un nom sur lequel porte la relation
  18. C 2) Placement après tous les noms sur lesquels porte la relation
  19. C * Au niveau des ddls :
  20. C a) Placement après tous les ddls sur lesquels porte la relation
  21. C b) Placement par points si le multiplicateur de Lagrange
  22. C est dans un espace d'éléments finis
  23. C 'APR2' = 1a ; 'APR3' = 1b ; 'APR4' = 2a ; 'APR5' = 2b
  24. C
  25. C
  26. C
  27. C LANGAGE : ESOPE
  28. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  29. C mél : gounand@semt2.smts.cea.fr
  30. C***********************************************************************
  31. C APPELES : FIXMEL, MLUNIQ, MKMPOS, MKNPOS, MAKPRM, MAKPMT
  32. C FUSPRM
  33. C APPELES (UTIL.) : FIMOTS, RSETXI, CUNIQ, CREPER, IUNIQ, ISETI
  34. C APPELES (STAT.) : INMSTA, PRMSTA
  35. C APPELE PAR : KRES2
  36. C***********************************************************************
  37. C ENTREES : MRENU, MMULAG
  38. C ENTREES/SORTIES : MATELE
  39. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  40. C***********************************************************************
  41. C VERSION : v1, 24/11/99, nouvelle version initiale
  42. C HISTORIQUE : v1, 30/09/99, création
  43. C HISTORIQUE : 05/01/00 : modif. appel fixmel
  44. C HISTORIQUE : 13/01/00 : Rajout d'une méthode de renumérotation avec
  45. C placement des multiplicateurs de Lagrange plus efficace
  46. C (cf. subroutine calnu2).
  47. C HISTORIQUE : 06/04/04 : Renumerotation
  48. C***********************************************************************
  49. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  50. C en cas de modification de ce sous-programme afin de faciliter
  51. C la maintenance !
  52. C***********************************************************************
  53. * MATASS est une matrice de préconditionnement déjà assemblée
  54. * permettant de sauter des étapes de l'assemblage
  55.  
  56. -INC PPARAM
  57. -INC CCOPTIO
  58. -INC SMCOORD
  59. -INC SMLENTI
  60. INTEGER JG
  61. POINTEUR KRSPGT.MLENTI
  62. POINTEUR KRSPGD.MLENTI
  63. C! POINTEUR KRILAG.MLENTI
  64. POINTEUR KRINCP.MLENTI
  65. POINTEUR KRINCD.MLENTI
  66. POINTEUR KRIPUN.MLENTI
  67. POINTEUR KRIDUN.MLENTI
  68. POINTEUR NEWNUM.MLENTI
  69. POINTEUR IWORK.MLENTI
  70. POINTEUR LITYP.MLENTI
  71. POINTEUR LINIV.MLENTI
  72. -INC SMLMOTS
  73. INTEGER JGM,JGN
  74. C! POINTEUR GPINCS.MLMOTS
  75. C! POINTEUR GPILAG.MLMOTS
  76. POINTEUR LITOT.MLMOTS
  77. C!*-INC SMLLOGI
  78. C! SEGMENT MLLOGI
  79. C! LOGICAL LOGI(JG)
  80. C! ENDSEGMENT
  81. C! POINTEUR LILAG.MLLOGI
  82. -INC SMELEME
  83. POINTEUR MELPRI.MELEME
  84. POINTEUR MELDUA.MELEME
  85. POINTEUR MELPR2.MELEME
  86. POINTEUR MELDU2.MELEME
  87. POINTEUR MLPPRI.MELEME
  88. POINTEUR MLPDUA.MELEME
  89. POINTEUR KJSPGT.MELEME
  90. POINTEUR MATELE.MATRIK
  91. POINTEUR IMATEL.IMATRI
  92. INTEGER NBI,NPT
  93. POINTEUR KMINCT.MINC
  94. INTEGER NTT,NJA
  95. POINTEUR PMTOT.PMORS
  96. INTEGER NBVA
  97. POINTEUR IZATOT.IZA
  98. POINTEUR PMTO2.PMORS
  99. POINTEUR IZATO2.IZA
  100. POINTEUR PMCOU.PMORS
  101. POINTEUR PMCO2.PMORS
  102. INTEGER NBLK
  103. POINTEUR IDMTOT.IDMAT
  104. *
  105. * Includes persos
  106. *
  107. * Segment avec diverses statistiques mémoire et CPU
  108. *STAT -INC SMSTAT
  109. *STAT POINTEUR MSTOT.MSTAT
  110. *STAT POINTEUR MSPRM.MSTAT
  111. *STAT POINTEUR MSMAT.MSTAT
  112. * Liste de MELEME
  113. INTEGER NBMEL
  114. SEGMENT MELS
  115. POINTEUR LISMEL(NBMEL).MELEME
  116. ENDSEGMENT
  117. POINTEUR GPMELS.MELS
  118. POINTEUR GPMLPP.MELS
  119. POINTEUR GPMLPD.MELS
  120. *
  121. INTEGER IMPR,IRET
  122. *
  123. REAL*8 RDUMMY(1)
  124. INTEGER IBI
  125. C! INTEGER NBMTOT,NBM,NBM2
  126. INTEGER IMATE
  127. INTEGER NMATE
  128. INTEGER NPOPRI,NPODUA
  129. INTEGER ITTDDL
  130. INTEGER NTOGPO,NTOTPO,NTOTIN,NTTDDL
  131. INTEGER NNZTOT
  132. INTEGER LNM,NME
  133. INTEGER NMEUNI
  134. INTEGER IPROFI,JOB
  135. LOGICAL LASEM,LSYM
  136. *
  137. C
  138. C Définition des options
  139. C
  140. INTEGER LNOPT
  141. PARAMETER (LNOPT=4)
  142. C algorithmes utilisés pour la renumérotation
  143. C * 'RIEN' : pas de renumérotation
  144. C * 'SLOA' : algorithme de chez Sloan
  145. C * 'GIPR' : Gibbs-King (profile reduction)
  146. C * 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
  147. CHARACTER*(LNOPT) MRENU
  148. INTEGER IRENU,NRENU
  149. PARAMETER (NRENU=4)
  150. POINTEUR LRENU.MLMOTS
  151. C algorithmes utilisés pour la prise en compte des mult.lag.
  152. C! a supprimmer
  153. C! * 'ECHA' : on renumérote tout puis on change
  154. C! de place les mulag pour les mettre après
  155. C! les ddl qui leur correspondent
  156. C! * 'APRE' : on renumérote sans les mult.lag. PUIS
  157. C! on les place après les ddl qui leur correspondent
  158. C! * 'APR2' : on renumérote avec les mult.lag. PUIS on les extrait
  159. C! on les replace après les ddl qui leur correspondent
  160. C * 'RIEN' : on ne fait rien de particulier pour les
  161. C multiplicateurs de lagrange
  162. C * 'APR3' : on ne fait rien de particulier pour les
  163. C multiplicateurs de lagrange
  164.  
  165. CHARACTER*(LNOPT) MMULAG
  166. INTEGER IMULAG,NMULAG
  167. C! PARAMETER (NMULAG=6)
  168. PARAMETER (NMULAG=5)
  169. POINTEUR LMULAG.MLMOTS
  170. C
  171. C Initialisation des tableaux d'options
  172. C
  173. JGN=LNOPT
  174. JGM=NRENU
  175. SEGINI LRENU
  176. LRENU.MOTS(1)='RIEN'
  177. LRENU.MOTS(2)='SLOA'
  178. LRENU.MOTS(3)='GIPR'
  179. LRENU.MOTS(4)='GIBA'
  180. JGN=LNOPT
  181. JGM=NMULAG
  182. SEGINI LMULAG
  183. C! LMULAG.MOTS(1)='ECHA'
  184. C! LMULAG.MOTS(2)='APRE'
  185. C! LMULAG.MOTS(3)='APR2'
  186. C! LMULAG.MOTS(4)='RIEN'
  187. C! LMULAG.MOTS(5)='APR3'
  188. C! LMULAG.MOTS(6)='APR4'
  189. LMULAG.MOTS(1)='RIEN'
  190. LMULAG.MOTS(2)='APR2'
  191. LMULAG.MOTS(3)='APR3'
  192. LMULAG.MOTS(4)='APR4'
  193. LMULAG.MOTS(5)='APR5'
  194. *
  195. * Executable statements
  196. *
  197. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prasem'
  198. *
  199. * Lecture des données (options renumérotation et mult.lag)
  200. *
  201. CALL FIMOTS(MRENU,LRENU,IRENU,IMPR,IRET)
  202. IF (IRET.NE.0) GOTO 9999
  203. CALL FIMOTS(MMULAG,LMULAG,IMULAG,IMPR,IRET)
  204. IF (IRET.NE.0) GOTO 9999
  205. SEGSUP LMULAG
  206. SEGSUP LRENU
  207. *STAT CALL INMSTA(MSTAT,IMPR)
  208. *STAT CALL INMSTA(MSTOT,0)
  209. *
  210. * Quelques tests
  211. *
  212. SEGACT MATELE
  213. NMATE=MATELE.IRIGEL(/2)
  214. IF (NMATE.LE.0) THEN
  215. WRITE(IOIMP,*) 'Pas de matrices élémentaires à assembler'
  216. GOTO 9999
  217. ENDIF
  218. PMTOT=MATELE.KIDMAT(4)
  219. LASEM=(PMTOT.NE.0)
  220. IF (LASEM.AND.IMPR.GT.0) THEN
  221. WRITE(IOIMP,*) 'Les matrices élémentaires sont déjà assemblées'
  222. ENDIF
  223. SEGDES MATELE
  224. IF (LASEM) GOTO 9998
  225. *STAT CALL PRMSTA(' Après les tests',MSTAT,IMPR)
  226. *
  227. * Correction des maillages (à supprimmer dès que possible)
  228. *
  229. SEGACT MATELE*MOD
  230. DO 11 IMATE=1,NMATE
  231. MELPRI=MATELE.IRIGEL(1,IMATE)
  232. MELDUA=MATELE.IRIGEL(2,IMATE)
  233. CALL FIXMEL(MELPRI,MELDUA,
  234. $ MELPR2,MELDU2,
  235. $ IMPR,IRET)
  236. IF (IRET.NE.0) GOTO 9999
  237. MATELE.IRIGEL(1,IMATE)=MELPR2
  238. MATELE.IRIGEL(2,IMATE)=MELDU2
  239. 11 CONTINUE
  240. SEGDES MATELE
  241. *STAT CALL PRMSTA(' Après fixmel',MSTAT,IMPR)
  242. *
  243. * Construire l'ensemble des points primaux et duaux pour chaque
  244. * matrice élémentaire (on ne veut plus utiliser les KSPGPs et KSPGDs
  245. * des IMATRI).
  246. *
  247. SEGACT MATELE
  248. NBMEL=NMATE
  249. SEGINI GPMLPP
  250. NBMEL=NMATE
  251. SEGINI GPMLPD
  252. NBMEL=1
  253. SEGINI GPMELS
  254. * In 12 : SEGINI GPMLPP.LISMEL(*)
  255. * In 12 : SEGINI GPMLPD.LISMEL(*)
  256. DO 12 IMATE=1,NMATE
  257. SEGACT GPMELS*MOD
  258. GPMELS.LISMEL(1)=MATELE.IRIGEL(1,IMATE)
  259. SEGDES GPMELS
  260. CALL MLUNIQ(GPMELS,MLPPRI,IMPR,IRET)
  261. IF (IRET.NE.0) GOTO 9999
  262. GPMLPP.LISMEL(IMATE)=MLPPRI
  263. SEGACT GPMELS*MOD
  264. GPMELS.LISMEL(1)=MATELE.IRIGEL(2,IMATE)
  265. SEGDES GPMELS
  266. CALL MLUNIQ(GPMELS,MLPDUA,IMPR,IRET)
  267. IF (IRET.NE.0) GOTO 9999
  268. GPMLPD.LISMEL(IMATE)=MLPDUA
  269. 12 CONTINUE
  270. SEGSUP GPMELS
  271. SEGDES MATELE
  272. *
  273. * Construire l'ensemble des points sur lesquels sont localisées des
  274. * inconnues (KJSPGT).
  275. *
  276. NBMEL=NMATE*2
  277. SEGINI GPMELS
  278. DO 1 IMATE=1,NMATE
  279. GPMELS.LISMEL(2*IMATE-1)=GPMLPP.LISMEL(IMATE)
  280. GPMELS.LISMEL(2*IMATE) =GPMLPD.LISMEL(IMATE)
  281. 1 CONTINUE
  282. CALL MLUNIQ(GPMELS,KJSPGT,IMPR,IRET)
  283. IF (IRET.NE.0) GOTO 9999
  284. SEGSUP GPMELS
  285. IF (IMPR.GT.3) THEN
  286. WRITE(IOIMP,*) 'L''ensemble des points est :'
  287. SEGPRT,KJSPGT
  288. ENDIF
  289. * Construire la liste de correspondance pour KJSPGT
  290. SEGACT KJSPGT
  291. NTOTPO=KJSPGT.NUM(/2)
  292. NTOGPO=nbpts
  293. JG=NTOGPO
  294. SEGINI KRSPGT
  295. * SEGACT KRSPGT
  296. CALL RSETXI(KRSPGT.LECT,KJSPGT.NUM,NTOTPO)
  297. *STAT CALL PRMSTA(' Construction KJSPGT et KRSPGT',MSTAT,IMPR)
  298. SEGDES KRSPGT
  299. SEGDES KJSPGT
  300. *
  301. * Construction de l'ensemble des noms d'inconnues possibles LITOT
  302. * et attribution d'un ordre.
  303. * On voudra qu'un ddl d'ordre i soit après au moins un ddl d'ordre
  304. * i-1 avec lequel il a une relation
  305. * LITOT : liste des noms d'inconnues
  306. * In INCOR2 : SEGINI LITOT SEGDES LITOT
  307. * SEGINI LINIV
  308. * SEGINI LITYP
  309. C!* CALL INCORD(MATELE,LITOT,LIORD,IMPR,IRET)
  310. CALL INCOR2(MATELE,IMULAG,LITOT,LITYP,LINIV,IMPR,IRET)
  311. IF (IRET.NE.0) GOTO 9999
  312. IF (IMPR.GT.3) THEN
  313. WRITE(IOIMP,*) 'L''ensemble des inconnues est :'
  314. SEGPRT,LITOT
  315. WRITE(IOIMP,*) 'Type :'
  316. SEGPRT,LITYP
  317. WRITE(IOIMP,*) 'Niveau :'
  318. SEGPRT,LINIV
  319. ENDIF
  320. *STAT CALL PRMSTA(' Construction LITOT',MSTAT,IMPR)
  321. *
  322. * Construire le repérage des inconnues KMINCT
  323. *
  324. SEGACT LITOT
  325. NTOTIN=LITOT.MOTS(/2)
  326. NPT=NTOTPO
  327. NBI=NTOTIN
  328. SEGINI KMINCT
  329. * Initialisation de la liste des noms d'inconnues (LISINC)
  330. DO 48 IBI=1,NBI
  331. KMINCT.LISINC(IBI)=LITOT.MOTS(IBI)(1:8)
  332. 48 CONTINUE
  333. SEGSUP LITOT
  334. * Construction de MPOS
  335. SEGACT KRSPGT
  336. SEGACT MATELE
  337. DO 5 IMATE=1,NMATE
  338. IMATEL=MATELE.IRIGEL(4,IMATE)
  339. SEGACT IMATEL
  340. * On parcourt la primale
  341. LNM=IMATEL.LISPRI(/1)
  342. NME=IMATEL.LISPRI(/2)
  343. JG=NME
  344. SEGINI KRINCP
  345. CALL CREPER(LNM,NME,NTOTIN,IMATEL.LISPRI,KMINCT.LISINC,
  346. $ KRINCP.LECT,
  347. $ IMPR,IRET)
  348. IF (IRET.NE.0) THEN
  349. WRITE(IOIMP,*) '1'
  350. GOTO 9999
  351. ENDIF
  352. * On supprimme les doublons dans KRINCP
  353. JG=NME
  354. SEGINI KRIPUN
  355. CALL IUNIQ(KRINCP.LECT,NME,
  356. $ KRIPUN.LECT,NMEUNI,
  357. $ IMPR,IRET)
  358. IF (IRET.NE.0) GOTO 9999
  359. SEGSUP KRINCP
  360. MLPPRI=GPMLPP.LISMEL(IMATE)
  361. SEGACT MLPPRI
  362. NPOPRI=MLPPRI.NUM(/2)
  363. CALL MKMPOS(NMEUNI,NPOPRI,NTOGPO,NTOTPO,NTOTIN,
  364. $ KRIPUN.LECT,MLPPRI.NUM,KRSPGT.LECT,
  365. $ KMINCT.MPOS,
  366. $ IMPR,IRET)
  367. SEGDES MLPPRI
  368. SEGSUP KRIPUN
  369. * On parcourt la duale
  370. LNM=IMATEL.LISDUA(/1)
  371. NME=IMATEL.LISDUA(/2)
  372. JG=NME
  373. SEGINI KRINCD
  374. CALL CREPER(LNM,NME,NTOTIN,
  375. $ IMATEL.LISDUA,KMINCT.LISINC,
  376. $ KRINCD.LECT,
  377. $ IMPR,IRET)
  378. IF (IRET.NE.0) THEN
  379. WRITE(IOIMP,*) '2'
  380. GOTO 9999
  381. ENDIF
  382. * On supprime les doublons dans KRINCD
  383. JG=NME
  384. SEGINI KRIDUN
  385. CALL IUNIQ(KRINCD.LECT,NME,
  386. $ KRIDUN.LECT,NMEUNI,
  387. $ IMPR,IRET)
  388. IF (IRET.NE.0) GOTO 9999
  389. SEGSUP KRINCD
  390. MLPDUA=GPMLPD.LISMEL(IMATE)
  391. SEGACT MLPDUA
  392. NPODUA=MLPDUA.NUM(/2)
  393. CALL MKMPOS(NMEUNI,NPODUA,NTOGPO,NTOTPO,NTOTIN,
  394. $ KRIDUN.LECT,MLPDUA.NUM,KRSPGT.LECT,
  395. $ KMINCT.MPOS,
  396. $ IMPR,IRET)
  397. IF (IRET.NE.0) GOTO 9999
  398. SEGDES MLPDUA
  399. SEGSUP KRIDUN
  400. SEGDES IMATEL
  401. 5 CONTINUE
  402. SEGDES KRSPGT
  403. *
  404. * Remplissage de NPOS(IPT) repérage dans le nb. total de ddl
  405. *
  406. CALL MKNPOS(NTOTPO,NTOTIN,KMINCT.MPOS,
  407. $ KMINCT.NPOS,
  408. $ IMPR,IRET)
  409. IF (IRET.NE.0) GOTO 9999
  410. IF (IMPR.GT.3) THEN
  411. WRITE(IOIMP,*) 'Le repérage des inconnues est :'
  412. SEGPRT,KMINCT
  413. ENDIF
  414. SEGDES KMINCT
  415. *STAT CALL PRMSTA(' Construction KMINCT',MSTAT,IMPR)
  416. *
  417. * On change de stratégie : on construit d'abord le profil Morse total
  418. * Puis, on le remplit avec le contenu des matrices élémentaires
  419. *
  420. * On construit le profil Morse diagonale pour initialiser
  421. *
  422. SEGACT KMINCT
  423. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  424. SEGDES KMINCT
  425. NTT=NTTDDL
  426. NJA=NTTDDL
  427. SEGINI PMTOT
  428. CALL ISETI(PMTOT.IA,NTTDDL+1)
  429. CALL ISETI(PMTOT.JA,NTTDDL)
  430. SEGDES PMTOT
  431. DO 7 IMATE=1,NMATE
  432. *STAT CALL INMSTA(MSPRM,0)
  433. MELPRI=MATELE.IRIGEL(1,IMATE)
  434. MELDUA=MATELE.IRIGEL(2,IMATE)
  435. IMATEL=MATELE.IRIGEL(4,IMATE)
  436. SEGACT IMATEL
  437. SEGACT KMINCT
  438. * repérage dans la primale
  439. LNM=IMATEL.LISPRI(/1)
  440. NME=IMATEL.LISPRI(/2)
  441. JG=NME
  442. SEGINI KRINCP
  443. CALL CREPER(LNM,NME,NTOTIN,
  444. $ IMATEL.LISPRI,KMINCT.LISINC,
  445. $ KRINCP.LECT,
  446. $ IMPR,IRET)
  447. IF (IRET.NE.0) THEN
  448. WRITE(IOIMP,*) '3'
  449. GOTO 9999
  450. ENDIF
  451. * repérage dans la duale
  452. LNM=IMATEL.LISDUA(/1)
  453. NME=IMATEL.LISDUA(/2)
  454. JG=NME
  455. SEGINI KRINCD
  456. CALL CREPER(LNM,NME,NTOTIN,
  457. $ IMATEL.LISDUA,KMINCT.LISINC,
  458. $ KRINCD.LECT,
  459. $ IMPR,IRET)
  460. IF (IRET.NE.0) THEN
  461. WRITE(IOIMP,*) '4'
  462. GOTO 9999
  463. ENDIF
  464. SEGDES KMINCT
  465. MLPDUA=GPMLPD.LISMEL(IMATE)
  466. SEGACT MLPDUA
  467. NPODUA=MLPDUA.NUM(/2)
  468. NTOGPO=nbpts
  469. JG=NTOGPO
  470. SEGINI KRSPGD
  471. CALL RSETXI(KRSPGD.LECT,MLPDUA.NUM,NPODUA)
  472. SEGDES MLPDUA
  473. *
  474. * Construire le profil Morse
  475. *
  476. * SEGINI PMCOU
  477. CALL MAKPRM(MELPRI,KRINCP,
  478. $ MELDUA,NPODUA,MLPDUA,KRSPGD,KRINCD,
  479. $ KMINCT,KRSPGT,
  480. $ PMCOU,
  481. $ IMPR,IRET)
  482. IF (IRET.NE.0) GOTO 9999
  483. SEGSUP KRSPGD
  484. SEGSUP KRINCD
  485. SEGSUP KRINCP
  486. SEGDES IMATEL
  487. *
  488. * Cas particulier : celui des matrices CCt
  489. *
  490. ITYMAT=MATELE.IRIGEL(7,IMATE)
  491. * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN
  492. IF (ITYMAT.EQ.4) THEN
  493. * In MAKPMT : SEGINI PMCO2
  494. CALL MAKPMT(PMCOU,
  495. $ PMCO2,
  496. $ IMPR,IRET)
  497. IF (IRET.NE.0) GOTO 9999
  498. SEGSUP PMCOU
  499. PMCOU=PMCO2
  500. ENDIF
  501. IF (IMPR.GT.3) THEN
  502. WRITE(IOIMP,*) 'Le ',IMATE,'eme profil Morse est :'
  503. SEGPRT,PMCOU
  504. ENDIF
  505. *STAT CALL PRMSTA(' Assemblage profil Morse élémentaire',MSPRM
  506. *STAT $ ,IMPR)
  507. *
  508. * on effectue le ET sur les profils Morse
  509. *
  510. * In FUSPRM : SEGINI PMTO2
  511. IF (METASS.EQ.1) THEN
  512. CALL FUSPRM(PMTOT,PMCOU,
  513. $ PMTO2,
  514. $ IMPR,IRET)
  515. IF (IRET.NE.0) GOTO 9999
  516. ELSEIF (METASS.EQ.2) THEN
  517. CALL FUSPR2(PMTOT,PMCOU,NTTDDL,
  518. $ PMTO2,
  519. $ IMPR,IRET)
  520. IF (IRET.NE.0) GOTO 9999
  521. ELSE
  522. WRITE(IOIMP,*) 'Programming error'
  523. GOTO 9999
  524. ENDIF
  525. SEGSUP PMCOU
  526. SEGSUP PMTOT
  527. PMTOT=PMTO2
  528. *STAT CALL PRMSTA(' Fusion profil Morse élémentaire',MSPRM,IMPR)
  529. 7 CONTINUE
  530. *STAT CALL PRMSTA(' Assemblage du profil Morse total',MSTAT,IMPR)
  531. *
  532. * Ordonnancement du profil Morse total
  533. *
  534. SEGACT PMTOT*MOD
  535. NTTDDL=PMTOT.IA(/1)-1
  536. NNZTOT=PMTOT.JA(/1)
  537. JG=MAX(NTTDDL+1,2*NNZTOT)
  538. SEGINI IWORK
  539. CALL CSORT(PMTOT.IA(/1)-1,RDUMMY,PMTOT.JA,PMTOT.IA,
  540. $ IWORK.LECT,.FALSE.)
  541. SEGSUP IWORK
  542. SEGDES PMTOT
  543. *STAT CALL PRMSTA(' Ordonnancement du profil Morse total',MSTAT,IMPR)
  544. *
  545. * Assemblage des matrices élémentaires
  546. *
  547. NBVA=NNZTOT
  548. SEGINI IZATOT
  549. SEGDES IZATOT
  550. DO 77 IMATE=1,NMATE
  551. *STAT CALL INMSTA(MSMAT,0)
  552. MELPRI=MATELE.IRIGEL(1,IMATE)
  553. MELDUA=MATELE.IRIGEL(2,IMATE)
  554. IMATEL=MATELE.IRIGEL(4,IMATE)
  555. SEGACT IMATEL
  556. SEGACT KMINCT
  557. * repérage dans la primale
  558. LNM=IMATEL.LISPRI(/1)
  559. NME=IMATEL.LISPRI(/2)
  560. JG=NME
  561. SEGINI KRINCP
  562. CALL CREPER(LNM,NME,NTOTIN,
  563. $ IMATEL.LISPRI,KMINCT.LISINC,
  564. $ KRINCP.LECT,
  565. $ IMPR,IRET)
  566. IF (IRET.NE.0) THEN
  567. WRITE(IOIMP,*) '5'
  568. GOTO 9999
  569. ENDIF
  570. * repérage dans la duale
  571. LNM=IMATEL.LISDUA(/1)
  572. NME=IMATEL.LISDUA(/2)
  573. JG=NME
  574. SEGINI KRINCD
  575. CALL CREPER(LNM,NME,NTOTIN,
  576. $ IMATEL.LISDUA,KMINCT.LISINC,
  577. $ KRINCD.LECT,
  578. $ IMPR,IRET)
  579. IF (IRET.NE.0) THEN
  580. WRITE(IOIMP,*) '6'
  581. GOTO 9999
  582. ENDIF
  583. SEGDES KMINCT
  584. CALL MKIZA(MELDUA,MELPRI,IMATEL,
  585. $ KRINCD,KRINCP,KMINCT,KRSPGT,
  586. $ PMTOT,
  587. $ IZATOT,
  588. $ IMPR,IRET)
  589. IF (IRET.NE.0) GOTO 9999
  590. *
  591. * Cas particulier : celui des matrices CCt
  592. *
  593. ITYMAT=MATELE.IRIGEL(7,IMATE)
  594. * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN
  595. IF (ITYMAT.EQ.4) THEN
  596. CALL MKIZAT(MELDUA,MELPRI,IMATEL,
  597. $ KRINCD,KRINCP,KMINCT,KRSPGT,
  598. $ PMTOT,
  599. $ IZATOT,
  600. $ IMPR,IRET)
  601. IF (IRET.NE.0) GOTO 9999
  602. ENDIF
  603. SEGSUP KRINCD
  604. SEGSUP KRINCP
  605. SEGDES IMATEL
  606. * CALL PRMSTA(' Assemblage mat. élémentaire',MSMAT,IMPR)
  607. 77 CONTINUE
  608. SEGSUP KRSPGT
  609. *STAT CALL PRMSTA(' Assemblage mat. élém. total',MSTAT,IMPR)
  610. *
  611. * Renumérotation
  612. *
  613. IF (IMPR.GT.3) THEN
  614. CALL PROFI2(PMTOT,IPROFI,IMPR,IRET)
  615. IF (IRET.NE.0) GOTO 9999
  616. WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
  617. ENDIF
  618. C!* Calcul
  619. C! IF (IMULAG.EQ.1) THEN
  620. C! CALL RENUME(PMTOT,IRENU,
  621. C! $ NEWNUM,
  622. C! $ IMPR,IRET)
  623. C! IF (IRET.NE.0) GOTO 9999
  624. C!* Modification de la nouvelle numérotation
  625. C!* pour placer les multiplicateurs de Lagrange
  626. C!* après les inconnues auxquelles ils se rapportent
  627. C! CALL MODNUM(LILAG,KMINCT,PMTOT,
  628. C! $ NEWNUM,
  629. C! $ IMPR,IRET)
  630. C! IF (IRET.NE.0) GOTO 9999
  631. C! ELSEIF (IMULAG.EQ.2) THEN
  632. C!* Autre facon de calculer la renumerotation
  633. C! CALL CALNUM(LILAG,KMINCT,PMTOT,
  634. C! $ IRENU,
  635. C! $ NEWNUM,
  636. C! $ IMPR,IRET)
  637. C! IF (IRET.NE.0) GOTO 9999
  638. C! ELSEIF (IMULAG.EQ.3) THEN
  639. C!* Dernière facon de calculer la renumerotation
  640. C! CALL CALNU2(LILAG,KMINCT,PMTOT,
  641. C! $ IRENU,
  642. C! $ NEWNUM,
  643. C! $ IMPR,IRET)
  644. C! IF (IRET.NE.0) GOTO 9999
  645. *!! ELSEIF (IMULAG.EQ.4) THEN
  646. IF (IMULAG.EQ.1) THEN
  647. CALL RENUME(PMTOT,IRENU,
  648. $ NEWNUM,
  649. $ IMPR,IRET)
  650. IF (IRET.NE.0) GOTO 9999
  651. C! ELSEIF (IMULAG.EQ.5) THEN
  652. C! CALL CALNU3(LIORD,KMINCT,PMTOT,
  653. C! $ IRENU,
  654. C! $ NEWNUM,
  655. C! $ IMPR,IRET)
  656. C! IF (IRET.NE.0) GOTO 9999
  657. ELSEIF (IMULAG.EQ.2.OR.IMULAG.EQ.4) THEN
  658. CALL CALNU4(LITYP,LINIV,KMINCT,PMTOT,
  659. $ IRENU,
  660. $ NEWNUM,
  661. $ IMPR,IRET)
  662. IF (IRET.NE.0) GOTO 9999
  663. ELSEIF (IMULAG.EQ.3.OR.IMULAG.EQ.5) THEN
  664. CALL CALNU5(LITYP,LINIV,KMINCT,PMTOT,
  665. $ IRENU,
  666. $ NEWNUM,
  667. $ IMPR,IRET)
  668. IF (IRET.NE.0) GOTO 9999
  669. ELSE
  670. WRITE(IOIMP,*) 'Erreur dans la programmation'
  671. WRITE(IOIMP,*) 'IMULAG=',IMULAG
  672. ENDIF
  673. SEGSUP LITYP
  674. SEGSUP LINIV
  675. *STAT CALL PRMSTA(' Calcul de la renumérotation',MSTAT,IMPR)
  676. * Permutation de la matrice
  677. SEGACT PMTOT
  678. SEGACT IZATOT
  679. NTT=PMTOT.IA(/1)-1
  680. NJA=PMTOT.JA(/1)
  681. SEGINI PMTO2
  682. NBVA=IZATOT.A(/1)
  683. SEGINI IZATO2
  684. SEGACT NEWNUM
  685. JOB=1
  686. CALL DPERM(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA,
  687. $ IZATO2.A,PMTO2.JA,PMTO2.IA,NEWNUM.LECT,NEWNUM.LECT,
  688. $ JOB)
  689. SEGDES NEWNUM
  690. SEGDES IZATO2
  691. SEGDES PMTO2
  692. SEGSUP PMTOT
  693. SEGSUP IZATOT
  694. PMTOT=PMTO2
  695. IZATOT=IZATO2
  696. *STAT CALL PRMSTA(' Permutation de la matrice',MSTAT,IMPR)
  697. * Ordonnancement des colonnes
  698. SEGACT PMTOT*MOD
  699. SEGACT IZATOT*MOD
  700. JG=MAX(PMTOT.IA(/1),2*PMTOT.JA(/1))
  701. SEGINI IWORK
  702. CALL CSORT(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA,
  703. $ IWORK.LECT,.TRUE.)
  704. SEGSUP IWORK
  705. SEGDES IZATOT
  706. SEGDES PMTOT
  707. *STAT CALL PRMSTA(' Ordonnancement des colonnes',MSTAT,IMPR)
  708. * Sauvegarde de la renumérotation
  709. NTT=0
  710. NPT=NTTDDL
  711. NBLK=0
  712. SEGACT NEWNUM
  713. SEGINI,IDMTOT
  714. DO 8 ITTDDL=1,NTTDDL
  715. IDMTOT.NUAN(ITTDDL)=NEWNUM.LECT(ITTDDL)
  716. 8 CONTINUE
  717. DO 9 ITTDDL=1,NTTDDL
  718. IDMTOT.NUNA(NEWNUM.LECT(ITTDDL))=ITTDDL
  719. 9 CONTINUE
  720. SEGDES IDMTOT
  721. SEGSUP NEWNUM
  722. * Suppression des supports de points primaux et duaux
  723. SEGSUP,GPMLPD.LISMEL(*)
  724. SEGSUP,GPMLPP.LISMEL(*)
  725. SEGSUP GPMLPD
  726. SEGSUP GPMLPP
  727. *
  728. * Affichage des infos sur la Matrice Morse
  729. *
  730. IF (IMPR.GT.3) THEN
  731. CALL PROFI2(PMTOT,IPROFI,IMPR,IRET)
  732. IF (IRET.NE.0) GOTO 9999
  733. WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
  734. ENDIF
  735. *
  736. * Remplissage du chapeau
  737. *
  738. SEGDES MATELE
  739. CALL ISMSYM(MATELE,
  740. $ LSYM,
  741. $ IMPR,IRET)
  742. IF (IRET.NE.0) GOTO 9999
  743. SEGACT MATELE*MOD
  744. IF (LSYM) THEN
  745. MATELE.KSYM=0
  746. ELSE
  747. MATELE.KSYM=2
  748. ENDIF
  749. MATELE.KMINC=KMINCT
  750. MATELE.KMINCP=KMINCT
  751. MATELE.KMINCD=KMINCT
  752. * MATELE.KIZM =MCONEC
  753. MATELE.KISPGT=KJSPGT
  754. MATELE.KISPGP=KJSPGT
  755. MATELE.KISPGD=KJSPGT
  756. SEGACT KMINCT
  757. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  758. SEGDES KMINCT
  759. MATELE.KNTTT=NTTDDL
  760. MATELE.KNTTP=NTTDDL
  761. MATELE.KNTTD=NTTDDL
  762. MATELE.KIDMAT(1)=IDMTOT
  763. MATELE.KIDMAT(2)=IDMTOT
  764. MATELE.KIDMAT(4)=PMTOT
  765. MATELE.KIDMAT(5)=IZATOT
  766. SEGDES MATELE
  767. *STAT CALL PRMSTA(' Fin de l''assemblage',MSTAT,IMPR)
  768. *STAT CALL PRMSTA('Total de l''assemblage',MSTOT,IMPR)
  769. *
  770. * Normal termination
  771. *
  772. 9998 CONTINUE
  773. IRET=0
  774. RETURN
  775. *
  776. * Format handling
  777. *
  778. *
  779. * Error handling
  780. *
  781. 9999 CONTINUE
  782. IRET=1
  783. WRITE(IOIMP,*) 'An error was detected in subroutine prasem'
  784. RETURN
  785. *
  786. * End of subroutine PRASEM
  787. *
  788. END
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  

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