Télécharger prase3.eso

Retour à la liste

Numérotation des lignes :

  1. C PRASE3 SOURCE PV 16/11/17 22:00:58 9180
  2. SUBROUTINE PRASE3(MATELE,MRENU,MMULAG,METASS,
  3. $ KTIME,LTIME,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : PRASE3
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : On effectue l'assemblage d'un ensemble de matrices
  11. C élémentaires pour faire une matrice Morse.
  12. C
  13. C
  14. C Quelques commentaires sur la numérotation pour le placement des
  15. C multiplicateurs de Lagrange :
  16. C
  17. C * Au niveau des noms d'inconnues :
  18. C 1) Placement juste après un nom sur lequel porte la relation
  19. C 2) Placement après tous les noms sur lesquels porte la relation
  20. C * Au niveau des ddls :
  21. C a) Placement après tous les ddls sur lesquels porte la relation
  22. C b) Placement par points si le multiplicateur de Lagrange
  23. C est dans un espace d'éléments finis
  24. C 'APR2' = 1a ; 'APR3' = 1b ; 'APR4' = 2a ; 'APR5' = 2b
  25. C
  26. C
  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 : FIXMEL, MLUNIQ, MKMPOS, MKNPOS, MAKPRM, MAKPMT
  33. C FUSPRM
  34. C APPELES (UTIL.) : FIMOTS, RSETXI, CUNIQ, CREPER, IUNIQ, ISETI
  35. C APPELES (STAT.) : INMSTA, PRMSTA
  36. C APPELE PAR : KRES2
  37. C***********************************************************************
  38. C ENTREES : MRENU, MMULAG
  39. C ENTREES/SORTIES : MATELE
  40. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  41. C***********************************************************************
  42. C VERSION : v1, 24/11/99, nouvelle version initiale
  43. C HISTORIQUE : v1, 30/09/99, création
  44. C HISTORIQUE : 05/01/00 : modif. appel fixmel
  45. C HISTORIQUE : 13/01/00 : Rajout d'une méthode de renumérotation avec
  46. C placement des multiplicateurs de Lagrange plus efficace
  47. C (cf. subroutine calnu2).
  48. C HISTORIQUE : 06/04/04 : Renumerotation
  49. C***********************************************************************
  50. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  51. C en cas de modification de ce sous-programme afin de faciliter
  52. C la maintenance !
  53. C***********************************************************************
  54. * MATASS est une matrice de préconditionnement déjà assemblée
  55. * permettant de sauter des étapes de l'assemblage
  56. -INC CCOPTIO
  57. -INC SMCOORD
  58. character*(*) mrenu, mmulag
  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. POINTEUR LDDLDU.MLENTI
  73. POINTEUR LDDLDT.MLENTI
  74. -INC SMLMOTS
  75. INTEGER JGM,JGN
  76. C! POINTEUR GPINCS.MLMOTS
  77. C! POINTEUR GPILAG.MLMOTS
  78. POINTEUR LITOT.MLMOTS
  79. C!*-INC SMLLOGI
  80. C! SEGMENT MLLOGI
  81. C! LOGICAL LOGI(JG)
  82. C! ENDSEGMENT
  83. C! POINTEUR LILAG.MLLOGI
  84. -INC SMELEME
  85. POINTEUR MELPRI.MELEME
  86. POINTEUR MELDUA.MELEME
  87. POINTEUR MELPR2.MELEME
  88. POINTEUR MELDU2.MELEME
  89. POINTEUR MLPPRI.MELEME
  90. POINTEUR MLPDUA.MELEME
  91. POINTEUR KJSPGT.MELEME
  92. POINTEUR MATELE.MATRIK
  93. POINTEUR IMATEL.IMATRI
  94. INTEGER NBI,NPT
  95. POINTEUR KMINCT.MINC
  96. INTEGER NTT,NJA
  97. POINTEUR PMTOT.PMORS
  98. INTEGER NBVA
  99. POINTEUR IZATOT.IZA
  100. POINTEUR PMTO2.PMORS
  101. POINTEUR IZATO2.IZA
  102. POINTEUR PMCOU.PMORS
  103. POINTEUR PMCO2.PMORS
  104. POINTEUR PMCOT.PMORS
  105. INTEGER NBLK
  106. POINTEUR IDMTOT.IDMAT
  107. -INC SMTABLE
  108. POINTEUR KTIME.MTABLE
  109. DIMENSION ITTIME(4)
  110. CHARACTER*8 CHARI
  111. LOGICAL LTIME
  112. *
  113. * Ensemble de profils morse
  114. *
  115. *
  116. * Includes persos
  117. *
  118. * Segment avec diverses statistiques mémoire et CPU
  119. *STAT -INC SMSTAT
  120. *STAT POINTEUR MSTOT.MSTAT
  121. *STAT POINTEUR MSPRM.MSTAT
  122. *STAT POINTEUR MSMAT.MSTAT
  123. * Liste de MELEME
  124. INTEGER NBMEL
  125. SEGMENT MELS
  126. POINTEUR LISMEL(NBMEL).MELEME
  127. ENDSEGMENT
  128. POINTEUR GPMELS.MELS
  129. POINTEUR GPMLPP.MELS
  130. POINTEUR GPMLPD.MELS
  131. *
  132. SEGMENT PMORSS
  133. POINTEUR LISDD(NBPM).MLENTI
  134. POINTEUR LISPM(NBPM).PMORS
  135. ENDSEGMENT
  136. *
  137. INTEGER IMPR,IRET
  138. *
  139. REAL*8 RDUMMY(1)
  140. INTEGER IBI
  141. C! INTEGER NBMTOT,NBM,NBM2
  142. INTEGER IMATE
  143. INTEGER NMATE
  144. INTEGER NPOPRI,NPODUA
  145. INTEGER ITTDDL
  146. INTEGER NTOGPO,NTOTPO,NTOTIN,NTTDDL
  147. INTEGER NNZTOT
  148. INTEGER LNM,NME
  149. INTEGER NMEUNI
  150. INTEGER IPROFI,JOB
  151. LOGICAL LASEM,LSYM,LOGII
  152. *
  153. C
  154. C Définition des options
  155. C
  156. C algorithmes utilisés pour la renumérotation
  157. C * 'RIEN' : pas de renumérotation
  158. C * 'SLOA' : algorithme de chez Sloan
  159. C * 'GIPR' : Gibbs-King (profile reduction)
  160. C * 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
  161. PARAMETER (NRENU=4)
  162. CHARACTER*4 LRENU(NRENU)
  163. C algorithmes utilisés pour la prise en compte des mult.lag.
  164. C! a supprimmer
  165. C! * 'ECHA' : on renumérote tout puis on change
  166. C! de place les mulag pour les mettre après
  167. C! les ddl qui leur correspondent
  168. C! * 'APRE' : on renumérote sans les mult.lag. PUIS
  169. C! on les place après les ddl qui leur correspondent
  170. C! * 'APR2' : on renumérote avec les mult.lag. PUIS on les extrait
  171. C! on les replace après les ddl qui leur correspondent
  172. C * 'RIEN' : on ne fait rien de particulier pour les
  173. C multiplicateurs de lagrange
  174. C * 'APR3' : on ne fait rien de particulier pour les
  175. C multiplicateurs de lagrange
  176.  
  177. PARAMETER (NMULAG=5)
  178. CHARACTER*4 LMULAG(NMULAG)
  179.  
  180. IVALI=0
  181. XVALI=REAL(0.D0)
  182. LOGII=.FALSE.
  183. IRETI=0
  184. XVALR=REAL(0.D0)
  185. IRETR=0
  186.  
  187. DATA LRENU/'RIEN','SLOA','GIPR','GIBA'/
  188. DATA LMULAG/'RIEN','APR2','APR3','APR4','APR5'/
  189. *
  190. * Executable statements
  191. *
  192. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prase3'
  193. IF (LTIME) THEN
  194. CALL TIMESPV(ITTIME)
  195. ITI1=(ITTIME(1)+ITTIME(2))/10
  196. ENDIF
  197. *
  198. * Lecture des données (options renumérotation et mult.lag)
  199. *
  200. CALL FICH4(MRENU,LRENU,NRENU,IRENU,IMPR,IRET)
  201. IF (IRET.NE.0) GOTO 9999
  202. CALL FICH4(MMULAG,LMULAG,NMULAG,IMULAG,IMPR,IRET)
  203. IF (IRET.NE.0) GOTO 9999
  204. *STAT CALL INMSTA(MSTAT,IMPR)
  205. *STAT CALL INMSTA(MSTOT,0)
  206. *
  207. * Quelques tests
  208. *
  209. SEGACT MATELE
  210. NMATE=MATELE.IRIGEL(/2)
  211. * WRITE(IOIMP,*) 'NMATE=',NMATE
  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. * On construit le profil Morse diagonale pour initialiser
  418. *
  419. NBPM=1
  420. DO IMATE=1,NMATE
  421. ITYMAT=MATELE.IRIGEL(7,IMATE)
  422. * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN
  423. IF (ITYMAT.EQ.4) THEN
  424. NBPM=NBPM+2
  425. ELSE
  426. NBPM=NBPM+1
  427. ENDIF
  428. ENDDO
  429. SEGINI PMORSS
  430. IPM=0
  431. *
  432. SEGACT KMINCT
  433. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  434. SEGDES KMINCT
  435. JG=NTTDDL
  436. SEGINI LDDLDU
  437. CALL ISETI(LDDLDU.LECT,NTTDDL)
  438. SEGDES LDDLDU
  439. NTT=NTTDDL
  440. NJA=NTTDDL
  441. SEGINI PMTOT
  442. CALL ISETI(PMTOT.IA,NTTDDL+1)
  443. CALL ISETI(PMTOT.JA,NTTDDL)
  444. SEGDES PMTOT
  445. *
  446. IPM=IPM+1
  447. PMORSS.LISDD(IPM)=LDDLDU
  448. PMORSS.LISPM(IPM)=PMTOT
  449. *
  450. DO 7 IMATE=1,NMATE
  451. *STAT CALL INMSTA(MSPRM,0)
  452. MELPRI=MATELE.IRIGEL(1,IMATE)
  453. MELDUA=MATELE.IRIGEL(2,IMATE)
  454. IMATEL=MATELE.IRIGEL(4,IMATE)
  455. SEGACT IMATEL
  456. SEGACT KMINCT
  457. * repérage dans la primale
  458. LNM=IMATEL.LISPRI(/1)
  459. NME=IMATEL.LISPRI(/2)
  460. JG=NME
  461. SEGINI KRINCP
  462. CALL CREPER(LNM,NME,NTOTIN,
  463. $ IMATEL.LISPRI,KMINCT.LISINC,
  464. $ KRINCP.LECT,
  465. $ IMPR,IRET)
  466. IF (IRET.NE.0) THEN
  467. WRITE(IOIMP,*) '3'
  468. GOTO 9999
  469. ENDIF
  470. * repérage dans la duale
  471. LNM=IMATEL.LISDUA(/1)
  472. NME=IMATEL.LISDUA(/2)
  473. JG=NME
  474. SEGINI KRINCD
  475. CALL CREPER(LNM,NME,NTOTIN,
  476. $ IMATEL.LISDUA,KMINCT.LISINC,
  477. $ KRINCD.LECT,
  478. $ IMPR,IRET)
  479. IF (IRET.NE.0) THEN
  480. WRITE(IOIMP,*) '4'
  481. GOTO 9999
  482. ENDIF
  483. SEGDES KMINCT
  484. MLPDUA=GPMLPD.LISMEL(IMATE)
  485. SEGACT MLPDUA
  486. NPODUA=MLPDUA.NUM(/2)
  487. NTOGPO=XCOOR(/1)/(IDIM+1)
  488. JG=NTOGPO
  489. SEGINI KRSPGD
  490. CALL RSETXI(KRSPGD.LECT,MLPDUA.NUM,NPODUA)
  491. SEGDES MLPDUA
  492. *
  493. * Construire le profil Morse
  494. *
  495. * SEGINI PMCOU
  496. CALL MAKPR2(MELPRI,KRINCP,
  497. $ MELDUA,NPODUA,MLPDUA,KRSPGD,KRINCD,
  498. $ KMINCT,KRSPGT,
  499. $ LDDLDU,PMCOU,
  500. $ IMPR,IRET)
  501. IF (IRET.NE.0) GOTO 9999
  502. IPM=IPM+1
  503. PMORSS.LISDD(IPM)=LDDLDU
  504. PMORSS.LISPM(IPM)=PMCOU
  505. * SEGPRT,LDDLDU
  506. * SEGPRT,PMCOU
  507. SEGSUP KRSPGD
  508. SEGSUP KRINCD
  509. SEGSUP KRINCP
  510. SEGDES IMATEL
  511. *
  512. * Cas particulier : celui des matrices CCt
  513. *
  514. ITYMAT=MATELE.IRIGEL(7,IMATE)
  515. * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN
  516. IF (ITYMAT.EQ.4) THEN
  517. * In MAKPMT : SEGINI PMCO2
  518. CALL TRPMO2(LDDLDU,PMCOU,NTTDDL,
  519. $ LDDLDT,PMCOT,
  520. $ IMPR,IRET)
  521. IPM=IPM+1
  522. PMORSS.LISDD(IPM)=LDDLDT
  523. PMORSS.LISPM(IPM)=PMCOT
  524. * SEGPRT,LDDLDT
  525. * SEGPRT,PMCOT
  526. ENDIF
  527. IF (IMPR.GT.3) THEN
  528. WRITE(IOIMP,*) 'Le ',IMATE,'eme profil Morse est :'
  529. SEGPRT,PMCOU
  530. ENDIF
  531. C CALL PRMSTA(' Assemblage profil Morse élémentaire',MSPRM
  532. C $ ,IMPR)
  533. 7 CONTINUE
  534. *STAT CALL PRMSTA(' Assemblage profils Morse élémentaire',MSPRM
  535. *STAT $ ,IMPR)
  536. *
  537. * on effectue le ET sur les profils Morse
  538. *
  539. * WRITE(IOIMP,*) 'METASS=',METASS
  540. IF (METASS.EQ.3) THEN
  541. CALL FUSPR3(PMORSS,NTTDDL,
  542. $ PMTOT,
  543. $ IMPR,IRET)
  544. IF (IRET.NE.0) GOTO 9999
  545. ELSEIF (METASS.EQ.4) THEN
  546. CALL FUSPR4(PMORSS,NTTDDL,
  547. $ PMTOT,
  548. $ IMPR,IRET)
  549. IF (IRET.NE.0) GOTO 9999
  550. ELSEIF (METASS.EQ.5) THEN
  551. CALL FUSPR5(PMORSS,NTTDDL,
  552. $ PMTOT,
  553. $ IMPR,IRET)
  554. IF (IRET.NE.0) GOTO 9999
  555. ELSE
  556. WRITE(IOIMP,*) 'Programming error'
  557. GOTO 9999
  558. ENDIF
  559. * WRITE(IOIMP,*) 'Apres fuspr'
  560. *
  561. * Suppression de PMORSS
  562. *
  563. DO IPM=1,PMORSS.LISDD(/1)
  564. LDDLDU=PMORSS.LISDD(IPM)
  565. SEGSUP LDDLDU
  566. PMCOU=PMORSS.LISPM(IPM)
  567. SEGSUP PMCOU
  568. ENDDO
  569. SEGSUP PMORSS
  570. * In FUSPRM : SEGINI PMTO2
  571. C CALL FUSPRM(PMTOT,PMCOU,
  572. C $ PMTO2,
  573. C $ IMPR,IRET)
  574. C IF (IRET.NE.0) GOTO 9999
  575. * CALL FUSPR2(PMTOT,PMCOU,NTTDDL,
  576. * $ PMTO2,
  577. * $ IMPR,IRET)
  578. * IF (IRET.NE.0) GOTO 9999
  579. C SEGSUP PMCOU
  580. C SEGSUP PMTOT
  581. C PMTOT=PMTO2
  582. *STAT CALL PRMSTA(' Fusion des profils Morse élémentaire',MSPRM,IMPR)
  583. *STAT CALL PRMSTA(' Assemblage du profil Morse total',MSTAT,IMPR)
  584. *
  585. * Essai d'une matrice avec plusieurs colonnes égales
  586. *
  587. C NTT=5
  588. C NJA=5
  589. C SEGINI PMTOT
  590. C PMTOT.IA(1)=1
  591. C PMTOT.IA(2)=1+NJA
  592. C PMTOT.IA(3)=1+NJA
  593. C PMTOT.IA(4)=1+NJA
  594. C PMTOT.IA(5)=1+NJA
  595. C PMTOT.IA(6)=1+NJA
  596. C PMTOT.JA(1)=3
  597. C PMTOT.JA(2)=3
  598. C PMTOT.JA(3)=2
  599. C PMTOT.JA(4)=1
  600. C PMTOT.JA(5)=2
  601. *
  602. * Ordonnancement du profil Morse total
  603. *
  604. SEGACT PMTOT*MOD
  605. * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1))
  606. * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1))
  607. NTTDDL=PMTOT.IA(/1)-1
  608. NNZTOT=PMTOT.JA(/1)
  609. JG=MAX(NTTDDL+1,2*NNZTOT)
  610. SEGINI IWORK
  611. CALL CSORT(PMTOT.IA(/1)-1,RDUMMY,PMTOT.JA,PMTOT.IA,
  612. $ IWORK.LECT,.FALSE.)
  613. SEGSUP IWORK
  614. SEGDES PMTOT
  615. *STAT CALL PRMSTA(' Ordonnancement du profil Morse total',MSTAT,IMPR)
  616. * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1))
  617. * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1))
  618. * 2020 FORMAT (20(2X,I4) )
  619. *
  620. *
  621. *
  622. * Compactage du profil Morse
  623. *
  624. IF (METASS.EQ.5) THEN
  625. PMORS=PMTOT
  626. SEGACT PMORS*MOD
  627. INEW=1
  628. NTT=IA(/1)-1
  629. DO ITT=1,NTT
  630. IDEB=IA(ITT)
  631. IFIN=IA(ITT+1)-1
  632. JNEW=-1
  633. IA(ITT)=INEW
  634. DO IJA=IDEB,IFIN
  635. JOLD=JA(IJA)
  636. IF (JNEW.NE.JOLD) THEN
  637. JNEW=JOLD
  638. JA(INEW)=JNEW
  639. INEW=INEW+1
  640. ENDIF
  641. ENDDO
  642. ENDDO
  643. IA(NTT+1)=INEW
  644. * WRITE(IOIMP,*) 'Compactage 1'
  645. * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1))
  646. * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1))
  647. * WRITE(IOIMP,*) 'ICUR=',ICUR
  648. * WRITE(IOIMP,*) 'IDEC=',IDEC
  649. * IA(NTT+1)=IA(NTT+1)-IDEC
  650. NJA=INEW-1
  651. SEGADJ PMORS
  652. SEGDES PMORS
  653. * WRITE(IOIMP,*) 'Compactage 2'
  654. * WRITE (IOIMP,2020) (PMTOT.IA(I),I=1,PMTOT.IA(/1))
  655. * WRITE (IOIMP,2020) (PMTOT.JA(I),I=1,PMTOT.JA(/1))
  656. ENDIF
  657. *
  658. * Assemblage des matrices élémentaires
  659. *
  660. NBVA=NNZTOT
  661. SEGINI IZATOT
  662. SEGDES IZATOT
  663. DO 77 IMATE=1,NMATE
  664. *STAT CALL INMSTA(MSMAT,0)
  665. MELPRI=MATELE.IRIGEL(1,IMATE)
  666. MELDUA=MATELE.IRIGEL(2,IMATE)
  667. IMATEL=MATELE.IRIGEL(4,IMATE)
  668. SEGACT IMATEL
  669. SEGACT KMINCT
  670. * repérage dans la primale
  671. LNM=IMATEL.LISPRI(/1)
  672. NME=IMATEL.LISPRI(/2)
  673. JG=NME
  674. SEGINI KRINCP
  675. CALL CREPER(LNM,NME,NTOTIN,
  676. $ IMATEL.LISPRI,KMINCT.LISINC,
  677. $ KRINCP.LECT,
  678. $ IMPR,IRET)
  679. IF (IRET.NE.0) THEN
  680. WRITE(IOIMP,*) '5'
  681. GOTO 9999
  682. ENDIF
  683. * repérage dans la duale
  684. LNM=IMATEL.LISDUA(/1)
  685. NME=IMATEL.LISDUA(/2)
  686. JG=NME
  687. SEGINI KRINCD
  688. CALL CREPER(LNM,NME,NTOTIN,
  689. $ IMATEL.LISDUA,KMINCT.LISINC,
  690. $ KRINCD.LECT,
  691. $ IMPR,IRET)
  692. IF (IRET.NE.0) THEN
  693. WRITE(IOIMP,*) '6'
  694. GOTO 9999
  695. ENDIF
  696. SEGDES KMINCT
  697. CALL MKIZA(MELDUA,MELPRI,IMATEL,
  698. $ KRINCD,KRINCP,KMINCT,KRSPGT,
  699. $ PMTOT,
  700. $ IZATOT,
  701. $ IMPR,IRET)
  702. IF (IRET.NE.0) GOTO 9999
  703. *
  704. * Cas particulier : celui des matrices CCt
  705. *
  706. ITYMAT=MATELE.IRIGEL(7,IMATE)
  707. * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN
  708. IF (ITYMAT.EQ.4) THEN
  709. CALL MKIZAT(MELDUA,MELPRI,IMATEL,
  710. $ KRINCD,KRINCP,KMINCT,KRSPGT,
  711. $ PMTOT,
  712. $ IZATOT,
  713. $ IMPR,IRET)
  714. IF (IRET.NE.0) GOTO 9999
  715. ENDIF
  716. SEGSUP KRINCD
  717. SEGSUP KRINCP
  718. SEGDES IMATEL
  719. * CALL PRMSTA(' Assemblage mat. élémentaire',MSMAT,IMPR)
  720. 77 CONTINUE
  721. SEGSUP KRSPGT
  722. *STAT CALL PRMSTA(' Assemblage mat. élém. total',MSTAT,IMPR)
  723. *
  724. * Renumérotation
  725. *
  726. IF (IMPR.GT.3) THEN
  727. CALL PROFI2(PMTOT,IPROFI,IMPR,IRET)
  728. IF (IRET.NE.0) GOTO 9999
  729. WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
  730. ENDIF
  731. *
  732. IF (LTIME) THEN
  733. CALL TIMESPV(ITTIME)
  734. ITI2=(ITTIME(1)+ITTIME(2))/10
  735. ENDIF
  736. C!* Calcul
  737. C! IF (IMULAG.EQ.1) THEN
  738. C! CALL RENUME(PMTOT,IRENU,
  739. C! $ NEWNUM,
  740. C! $ IMPR,IRET)
  741. C! IF (IRET.NE.0) GOTO 9999
  742. C!* Modification de la nouvelle numérotation
  743. C!* pour placer les multiplicateurs de Lagrange
  744. C!* après les inconnues auxquelles ils se rapportent
  745. C! CALL MODNUM(LILAG,KMINCT,PMTOT,
  746. C! $ NEWNUM,
  747. C! $ IMPR,IRET)
  748. C! IF (IRET.NE.0) GOTO 9999
  749. C! ELSEIF (IMULAG.EQ.2) THEN
  750. C!* Autre facon de calculer la renumerotation
  751. C! CALL CALNUM(LILAG,KMINCT,PMTOT,
  752. C! $ IRENU,
  753. C! $ NEWNUM,
  754. C! $ IMPR,IRET)
  755. C! IF (IRET.NE.0) GOTO 9999
  756. C! ELSEIF (IMULAG.EQ.3) THEN
  757. C!* Dernière facon de calculer la renumerotation
  758. C! CALL CALNU2(LILAG,KMINCT,PMTOT,
  759. C! $ IRENU,
  760. C! $ NEWNUM,
  761. C! $ IMPR,IRET)
  762. C! IF (IRET.NE.0) GOTO 9999
  763. *!! ELSEIF (IMULAG.EQ.4) THEN
  764. IF (IMULAG.EQ.1) THEN
  765. CALL RENUME(PMTOT,IRENU,
  766. $ NEWNUM,
  767. $ IMPR,IRET)
  768. IF (IRET.NE.0) GOTO 9999
  769. C! ELSEIF (IMULAG.EQ.5) THEN
  770. C! CALL CALNU3(LIORD,KMINCT,PMTOT,
  771. C! $ IRENU,
  772. C! $ NEWNUM,
  773. C! $ IMPR,IRET)
  774. C! IF (IRET.NE.0) GOTO 9999
  775. ELSEIF (IMULAG.EQ.2.OR.IMULAG.EQ.4) THEN
  776. CALL CALNU4(LITYP,LINIV,KMINCT,PMTOT,
  777. $ IRENU,
  778. $ NEWNUM,
  779. $ IMPR,IRET)
  780. IF (IRET.NE.0) GOTO 9999
  781. ELSEIF (IMULAG.EQ.3.OR.IMULAG.EQ.5) THEN
  782. CALL CALNU5(LITYP,LINIV,KMINCT,PMTOT,
  783. $ IRENU,
  784. $ NEWNUM,
  785. $ IMPR,IRET)
  786. IF (IRET.NE.0) GOTO 9999
  787. ELSE
  788. WRITE(IOIMP,*) 'Erreur dans la programmation'
  789. WRITE(IOIMP,*) 'IMULAG=',IMULAG
  790. ENDIF
  791. SEGSUP LITYP
  792. SEGSUP LINIV
  793. IF (LTIME) THEN
  794. CALL TIMESPV(ITTIME)
  795. ITI3=(ITTIME(1)+ITTIME(2))/10
  796. ENDIF
  797. *STAT CALL PRMSTA(' Calcul de la renumérotation',MSTAT,IMPR)
  798. * Permutation de la matrice
  799. SEGACT PMTOT
  800. SEGACT IZATOT
  801. NTT=PMTOT.IA(/1)-1
  802. NJA=PMTOT.JA(/1)
  803. SEGINI PMTO2
  804. NBVA=IZATOT.A(/1)
  805. SEGINI IZATO2
  806. SEGACT NEWNUM
  807. JOB=1
  808. CALL DPERM(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA,
  809. $ IZATO2.A,PMTO2.JA,PMTO2.IA,NEWNUM.LECT,NEWNUM.LECT,
  810. $ JOB)
  811. SEGDES NEWNUM
  812. SEGDES IZATO2
  813. SEGDES PMTO2
  814. SEGSUP PMTOT
  815. SEGSUP IZATOT
  816. PMTOT=PMTO2
  817. IZATOT=IZATO2
  818. *STAT CALL PRMSTA(' Permutation de la matrice',MSTAT,IMPR)
  819. * Ordonnancement des colonnes
  820. SEGACT PMTOT*MOD
  821. SEGACT IZATOT*MOD
  822. JG=MAX(PMTOT.IA(/1),2*PMTOT.JA(/1))
  823. SEGINI IWORK
  824. CALL CSORT(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA,
  825. $ IWORK.LECT,.TRUE.)
  826. SEGSUP IWORK
  827. SEGDES IZATOT
  828. SEGDES PMTOT
  829. *STAT CALL PRMSTA(' Ordonnancement des colonnes',MSTAT,IMPR)
  830. * Sauvegarde de la renumérotation
  831. NTT=0
  832. NPT=NTTDDL
  833. NBLK=0
  834. SEGACT NEWNUM
  835. SEGINI,IDMTOT
  836. DO 8 ITTDDL=1,NTTDDL
  837. IDMTOT.NUAN(ITTDDL)=NEWNUM.LECT(ITTDDL)
  838. 8 CONTINUE
  839. DO 9 ITTDDL=1,NTTDDL
  840. IDMTOT.NUNA(NEWNUM.LECT(ITTDDL))=ITTDDL
  841. 9 CONTINUE
  842. SEGDES IDMTOT
  843. SEGSUP NEWNUM
  844. * Suppression des supports de points primaux et duaux
  845. SEGSUP,GPMLPD.LISMEL(*)
  846. SEGSUP,GPMLPP.LISMEL(*)
  847. SEGSUP GPMLPD
  848. SEGSUP GPMLPP
  849. *
  850. * Affichage des infos sur la Matrice Morse
  851. *
  852. IF (IMPR.GT.3) THEN
  853. CALL PROFI2(PMTOT,IPROFI,IMPR,IRET)
  854. IF (IRET.NE.0) GOTO 9999
  855. WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI
  856. ENDIF
  857. *
  858. * Remplissage du chapeau
  859. *
  860. SEGDES MATELE
  861. CALL ISMSYM(MATELE,
  862. $ LSYM,
  863. $ IMPR,IRET)
  864. IF (IRET.NE.0) GOTO 9999
  865. SEGACT MATELE*MOD
  866. IF (LSYM) THEN
  867. MATELE.KSYM=0
  868. ELSE
  869. MATELE.KSYM=2
  870. ENDIF
  871. MATELE.KMINC=KMINCT
  872. MATELE.KMINCP=KMINCT
  873. MATELE.KMINCD=KMINCT
  874. * MATELE.KIZM =MCONEC
  875. MATELE.KISPGT=KJSPGT
  876. MATELE.KISPGP=KJSPGT
  877. MATELE.KISPGD=KJSPGT
  878. SEGACT KMINCT
  879. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  880. SEGDES KMINCT
  881. MATELE.KNTTT=NTTDDL
  882. MATELE.KNTTP=NTTDDL
  883. MATELE.KNTTD=NTTDDL
  884. MATELE.KIDMAT(1)=IDMTOT
  885. MATELE.KIDMAT(2)=IDMTOT
  886. MATELE.KIDMAT(4)=PMTOT
  887. MATELE.KIDMAT(5)=IZATOT
  888. SEGDES MATELE
  889. IF (LTIME) THEN
  890. CALL TIMESPV(ITTIME)
  891. ITI4=(ITTIME(1)+ITTIME(2))/10
  892. ITN=ITI3-ITI2
  893. ITR=(ITI4-ITI1)-ITN
  894. CHARI='RENUMERO'
  895. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  896. $ 'ENTIER ',ITN,XVALR,CHARR,LOGIR,IRETR)
  897. CHARI='ASSEMBLA'
  898. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  899. $ 'ENTIER ',ITR,XVALR,CHARR,LOGIR,IRETR)
  900. ENDIF
  901. *STAT CALL PRMSTA(' Fin de l''assemblage',MSTAT,IMPR)
  902. *STAT CALL PRMSTA('Total de l''assemblage',MSTOT,IMPR)
  903. *
  904. * Normal termination
  905. *
  906. 9998 CONTINUE
  907. IRET=0
  908. RETURN
  909. *
  910. * Format handling
  911. *
  912. *
  913. * Error handling
  914. *
  915. 9999 CONTINUE
  916. IRET=1
  917. WRITE(IOIMP,*) 'An error was detected in subroutine prase3'
  918. RETURN
  919. *
  920. * End of subroutine PRASE3
  921. *
  922. END
  923.  
  924.  
  925.  
  926.  
  927.  
  928.  
  929.  
  930.  
  931.  
  932.  
  933.  
  934.  
  935.  
  936.  
  937.  

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