Télécharger prasem.eso

Retour à la liste

Numérotation des lignes :

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

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