Télécharger la plaquette Cast3M


fr en

Télécharger prasem.eso

Retour à la liste

Numérotation des lignes : 

prasem

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

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