Télécharger prase3.eso

Retour à la liste

Numérotation des lignes :

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

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