Télécharger la plaquette Cast3M


fr en

Télécharger prase3.eso

Retour à la liste

Numérotation des lignes : 

prase3

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

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