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

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