Télécharger la plaquette Cast3M


fr en

Télécharger calnu4.eso

Retour à la liste

Numérotation des lignes : 

calnu4

  1. C CALNU4    SOURCE    PV        20/09/26    21:15:24     10724          
  2.       SUBROUTINE CALNU4(LITYP,LINIV,KMINCT,PMTOT,
  3.      $     IRENU,
  4.      $     NEWNUM,
  5.      $     IMPR,IRET)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.       IMPLICIT INTEGER (I-N)
  8. C***********************************************************************
  9. C NOM         : CALNU4
  10. C PROJET      : Noyau linéaire NLIN
  11. C DESCRIPTION : Calcul d'une renumérotation avec minimisation d'un
  12. C               profil PUIS placement des inconnues suivant l'ordre
  13. C               donné par LIORD
  14. C               Dans calnum, on effectuait les choses suivantes :
  15. C               - minimisation du profil sur les ddl sans les ML.
  16. C               - insertion des ML dans la nouvelle numérotation
  17. C               Maintenant, on essaie la chose suivante :
  18. C               - minimisation du profil sur les ddl AVEC les ML.;
  19. C               - retrait des ML de la numérotation ;
  20. C               - réinsertion des ML pour les placer après les ddl non
  21. C                 ML auxquels ils sont liés.
  22. C
  23. C  IRENU=1 'RIEN' : pas de renumérotation
  24. C        2 'SLOA' : algorithme de chez Sloan
  25. C        3 'GIPR' : Gibbs-King (profile reduction)
  26. C        4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
  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          : RENUME
  33. C APPELES (UTIL.)  : ISETI, ISHELI, RSETXI
  34. C APPELE PAR       : PRASEM
  35. C***********************************************************************
  36. C ENTREES            : KMINCT, PMTOT, IRENU
  37. C SORTIES            : NEWNUM
  38. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  39. C***********************************************************************
  40. C VERSION    : v1, 01/04/04, version initiale
  41. C HISTORIQUE : v1, 01/04/04, création
  42. C HISTORIQUE : voir note * SG 10/06/2015
  43. C HISTORIQUE :
  44. C***********************************************************************
  45. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  46. C en cas de modification de ce sous-programme afin de faciliter
  47. C la maintenance !
  48. C***********************************************************************
  49.  
  50. -INC PPARAM
  51. -INC CCOPTIO
  53.       POINTEUR KMINCT.MINC
  54.       POINTEUR PMTOT.PMORS
  55. -INC SMLENTI
  56.       INTEGER JG
  57.       POINTEUR LITYP.MLENTI
  58.       POINTEUR LINIV.MLENTI
  59.       POINTEUR DDLINC.MLENTI
  60. *inu      POINTEUR DDLPT.MLENTI
  61.       POINTEUR NEWNUM.MLENTI
  62.       POINTEUR KRDDL.MLENTI
  63.       POINTEUR NNUTOT.MLENTI
  64.       POINTEUR PRMDDL.MLENTI
  65.       SEGMENT LML
  66.       POINTEUR ML(NINC).MLENTI
  67.       ENDSEGMENT
  68.       POINTEUR DDLDIM.MLENTI
  69.       POINTEUR ITTDDL.MLENTI
  70.       POINTEUR INUDDL.MLENTI
  71.       POINTEUR LDD.LML
  72.       POINTEUR LDDI.MLENTI
  73.       POINTEUR NNU.LML
  74.       POINTEUR NNUI.MLENTI
  75.       POINTEUR NNUJ.MLENTI
  76.       POINTEUR NNUK.MLENTI
  77.       POINTEUR PRM.LML
  78.       POINTEUR PRMI.MLENTI
  79. *-INC SMLLOGI
  80.       SEGMENT MLLOGI
  81.       LOGICAL LOGI(JG)
  82.       ENDSEGMENT
  83.       POINTEUR DDLOK.MLLOGI
  84. *      POINTEUR PTLAG.MLLOGI
  85.       POINTEUR DDLLAG.MLLOGI
  86. *
  87. *STAT-INC SMSTAT
  88. *
  89.       INTEGER IMPR,IRET
  90.       INTEGER IRENU
  91. *
  92.       INTEGER ITOTPO,JTTDDL
  93.       INTEGER NTOTPO,NTTDDL
  94.       LOGICAL LLAG,LRELA
  95. *
  96. * Executable statements
  97. *
  98.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans calnu4'
  99. *
  100. * Construction de DDLINC : c'est un tableau d'entiers tel que :
  101. * DDLINC(jttddl) = ordre du ddl
  102. *
  103. *      SEGPRT,KMINCT
  104. *      SEGPRT,PMTOT
  105. *      SEGPRT,LITYP
  106. *      SEGPRT,LINIV
  107.       SEGACT KMINCT
  108.       SEGACT LITYP
  109.       SEGACT LINIV
  110.       NINC=KMINCT.LISINC(/2)
  111.       MAXNIV=0
  112.       DO IINC=1,NINC
  113.          MAXNIV=MAX(MAXNIV,LINIV.LECT(IINC))
  114.       ENDDO
  115. *
  116. * Construction de DDLINC et DDLPT : sorte de segment réciproque
  117. *              de KMINCT
  118. * En fait, DDLPT est inutile pour la suite.
  119. * Construction de DDLLAG : liste des ddl de niveau > 1
  120. *
  121.       NTOTPO=KMINCT.NPOS(/1)-1
  122.       NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  123.       JG=NTTDDL
  124.       SEGINI DDLINC
  125. *inu      JG=NTTDDL
  126. *inu      SEGINI DDLPT
  127.       JG=NTTDDL
  128. * Initialisé à .FALSE.
  129.       SEGINI DDLLAG
  130.       LRELA=.FALSE.
  131.       DO ITOTPO=1,NTOTPO
  132.          DO IINC=1,NINC
  133.             IPOS=KMINCT.MPOS(ITOTPO,IINC)
  134.             IF (IPOS.NE.0) THEN
  135.                JPOS=KMINCT.NPOS(ITOTPO)+IPOS-1
  136.                DDLINC.LECT(JPOS)=IINC
  137. *inu               DDLPT.LECT(JPOS)=ITOTPO
  138. * Non !               IF (LITYP.LECT(IINC).LE.2) THEN
  139.                IF (LINIV.LECT(IINC).GE.2) THEN
  140.                   DDLLAG.LOGI(JPOS)=.TRUE.
  141.                   LRELA=.TRUE.
  142.                ENDIF
  143.             ENDIF
  144.          ENDDO
  145.       ENDDO
  146. *      SEGPRT,DDLINC
  147. *inu      SEGPRT,DDLPT
  148. *      SEGPRT,DDLLAG
  149. *dbg      DO ITTDDL=1,NTTDDL
  150. *dbg         CALL DDL2PI(ITTDDL,KMINCT,
  151. *dbg     $        IPT,IBI,
  152. *dbg     $        IMPR,IRET)
  153. *dbg         IF (IRET.NE.0) GOTO 9999
  154. *dbg         WRITE(IOIMP,*) 'ddl ',ITTDDL,' = IPT=',IPT,
  155. *dbg     $        ' inconnue ',KMINCT.LISINC(IBI)
  156. *dbg      ENDDO
  157. *inu   SEGSUP DDLPT
  158. *
  159. * Construction des tableaux d'entiers suivants :
  160. *   LDD.IINC(1..NTTINC) liste des ddl de l'inconnue iinc
  161. *   DDLINC(JTTDDL)=IINC : numéro de l'inconnue du ddl de numéro jttddl
  162. *   KRDDL(JTTDDL)=ITTINC avec LDD.IINC(ITTINC)
  163. *
  164.       SEGINI LDD
  165.       JG=NINC
  166.       SEGINI DDLDIM
  167.       DO IINC=1,NINC
  168.          JG=0
  169.          SEGINI LDDI
  170.          LDD.ML(IINC)=LDDI
  171.       ENDDO
  172.       JG=NTTDDL
  173.       SEGINI KRDDL
  174.       DO JTTDDL=1,NTTDDL
  175.          IINC=DDLINC.LECT(JTTDDL)
  176.          LDDI=LDD.ML(IINC)
  177.          ITTINC=DDLDIM.LECT(IINC)+1
  178.          LDDI.LECT(**)=JTTDDL
  179.          KRDDL.LECT(JTTDDL)=ITTINC
  180.          DDLDIM.LECT(IINC)=ITTINC
  181.       ENDDO
  182. C      SEGPRT,DDLDIM
  183. C      SEGPRT,LDD
  184. C      DO IINC=1,NINC
  185. C         LDDI=LDD.ML(IINC)
  186. C         SEGPRT,LDDI
  187. C      ENDDO
  188. C      SEGPRT,KRDDL
  189. *STAT         CALL PRMSTA('    Préparation renume divers',MSTAT,IMPR)
  190. *
  191. * Obtention de la nouvelle numérotation des ddl
  192. * In RENUME : SEGINI NNUTOT
  193. * In RENUME : SEGDES NNUTOT
  194.       CALL RENUME(PMTOT,IRENU,NNUTOT,IMPR,IRET)
  195.       IF (IRET.NE.0) GOTO 9999
  196. C      SEGPRT,NNUTOT
  197. *STAT         CALL PRMSTA('    Après renume',MSTAT,IMPR)
  198. *
  199. * Construction des NNUs pour les points qui ne sont pas dans
  200. * DDLLAG
  201. *
  202.       SEGACT,NNUTOT
  203. * NINC=NINC
  204.       SEGINI NNU
  205.       DO IINC=1,NINC
  206.          JG=DDLDIM.LECT(IINC)
  207.          SEGINI NNUI
  208.          NNU.ML(IINC)=NNUI
  209.       ENDDO
  210.       DO ITOTPO=1,NTOTPO
  211.          DO IINC=1,NINC
  212.             IPOS=KMINCT.MPOS(ITOTPO,IINC)
  213.             IF (IPOS.NE.0) THEN
  214.                JPOS=KMINCT.NPOS(ITOTPO)+IPOS-1
  215. * SG 10/06/2015  IF (.NOT.DDLLAG.LOGI(JPOS)) THEN
  216.                   INNU=NNUTOT.LECT(JPOS)
  217.                   NNUI=NNU.ML(IINC)
  218.                   KRNNUI=KRDDL.LECT(JPOS)
  219.                   NNUI.LECT(KRNNUI)=INNU
  220. * SG 10/06/2015  ENDIF
  221.             ENDIF
  222.          ENDDO
  223.       ENDDO
  224.       SEGSUP NNUTOT
  225. *      SEGPRT,NNU
  226. *      DO IINC=1,NINC
  227. *         NNUI=NNU.ML(IINC)
  228. *         SEGPRT,NNUI
  229. *      ENDDO
  230.  
  231.       IF (LRELA) THEN
  232. C
  233. C Obtention des numéros des ddl portant sur des points
  234. C où il n'y a que des multiplicateurs de Lagrange
  235. C le max ou le min des ddl de niveau INIV-1 qui lui sont
  236. C reliés
  237. C
  238.          SEGACT PMTOT
  239.          DO INIV=2,MAXNIV
  240.             DO IINC=1,NINC
  241.                JNIV=LINIV.LECT(IINC)
  242.                IF (JNIV.EQ.INIV) THEN
  243.                   JTYP=LITYP.LECT(IINC)
  244.                   DO ITOTPO=1,NTOTPO
  245.                      IPOS=KMINCT.MPOS(ITOTPO,IINC)
  246.                      IF (IPOS.NE.0) THEN
  247.                         JTTDDL=KMINCT.NPOS(ITOTPO)+IPOS-1
  248.                         IF (DDLLAG.LOGI(JTTDDL)) THEN
  249. *                           WRITE(IOIMP,*) 'Lagrange JTTDDL=',JTTDDL
  250.                            JNNU=0
  251.                            KSTRT=PMTOT.IA(JTTDDL)
  252.                            KSTOP=PMTOT.IA(JTTDDL+1)-1
  253. *                           WRITE(IOIMP,*) 'iniv-1=',INIV-1
  254. *                           WRITE(IOIMP,*) 'kstrt=',kstrt
  255. *                           WRITE(IOIMP,*) 'kstop=',kstop
  256.                            DO KIND=KSTRT,KSTOP
  257.                               KTTDDL=PMTOT.JA(KIND)
  258.                               KINC=DDLINC.LECT(KTTDDL)
  259.                               KNIV=LINIV.LECT(KINC)
  260. *                              WRITE(IOIMP,*) 'kniv=',KNIV
  261.                               IF (KNIV.LE.INIV-1) THEN
  262.                                  NNUK=NNU.ML(KINC)
  263.                                  KRNNUK=KRDDL.LECT(KTTDDL)
  264.                                  KNNU=NNUK.LECT(KRNNUK)
  265. *                                 WRITE(IOIMP,*) 'ok knnu=',KNNU
  266.                                  IF (KNNU.EQ.0) THEN
  267.                                     WRITE(IOIMP,*) 'Erreur trop grave'
  268.                                     GOTO 9999
  269.                                  ENDIF
  270.                                  IF (JNNU.EQ.0) THEN
  271.                                     JNNU=KNNU
  272.                                  ELSE
  273.                                     IF (JTYP.EQ.4) THEN
  274.                                        JNNU=MIN(JNNU,KNNU)
  275. *!                                    ELSEIF (JTYP.EQ.3) THEN
  276.                                     ELSEIF (JTYP.EQ.3.OR.JTYP.EQ.2) THEN
  277.                                        JNNU=MAX(JNNU,KNNU)
  278.                                     ELSE
  279.                                        WRITE(IOIMP,*) 'Erreur grave 1.2'
  280.                                        GOTO 9999
  281.                                     ENDIF
  282.                                  ENDIF
  283.                               ENDIF
  284.                            ENDDO
  285.                            IF (JNNU.EQ.0) THEN
  286. * SG 10/06/2015
  287. * Ceci peut ne pas etre une erreur apres elimination des relations,
  288. * il peut y avoir des multiplicateurs qui se retrouvent seuls
  289. * ce qui n'est pas un pb s'ils ont une matrice de stabilisation pour
  290. * eux.
  291. * A ce moment-là, on ne change pas leur position dans le profil
  292. * i.e on ne fait rien
  293. * Ceci etait l'ancien debug...
  294.                               if (.FALSE.) THEN
  295.                                  WRITE(IOIMP,*) 'INIV=',INIV
  296.                                  WRITE(IOIMP,*) 'IINC=',IINC
  297.                                  WRITE(IOIMP,*) 'JTYP=',JTYP
  298.                                  WRITE(IOIMP,*) 'JTTDDL=',JTTDDL
  299.                                  DO KIND=KSTRT,KSTOP
  300.                                     KTTDDL=PMTOT.JA(KIND)
  301.                                     WRITE(IOIMP,*) 'KTTDDL=',KTTDDL
  302.                                     KINC=DDLINC.LECT(KTTDDL)
  303.                                     KNIV=LINIV.LECT(KINC)
  304.                                     WRITE(IOIMP,*) 'KINC=',KINC
  305.                                     WRITE(IOIMP,*) 'KNIV=',KNIV
  306.                                  ENDDO
  307.                                  WRITE(IOIMP,*) 'Erreur grave 1.5'
  308.                                  GOTO 9999
  309.                               endif
  310.                            ELSE
  311.                               NNUJ=NNU.ML(IINC)
  312.                               KRNNUJ=KRDDL.LECT(JTTDDL)
  313.                               NNUJ.LECT(KRNNUJ)=JNNU
  314.                            ENDIF
  315.                         ENDIF
  316.                      ENDIF
  317.                   ENDDO
  318.                ENDIF
  319.             ENDDO
  320.          ENDDO
  321.          SEGDES PMTOT
  322.       ENDIF
  323. C      SEGPRT,NNU
  324. C      DO IINC=1,NINC
  325. C         NNUI=NNU.ML(IINC)
  326. C         SEGPRT,NNUI
  327. C      ENDDO
  328.       SEGSUP KRDDL
  329.       SEGSUP DDLLAG
  330.       SEGSUP DDLINC
  331.       SEGDES LINIV
  332.       SEGDES LITYP
  333.       SEGDES KMINCT
  334. *
  335. * 1 On calcule les permutations qui permettent de trier NNU
  336. *   par ordre croissant de nouveau numéro.
  337. *
  338.       SEGINI PRM
  339.       DO IINC=1,NINC
  340.          NTTINC=DDLDIM.LECT(IINC)
  341.          JG=NTTINC
  342.          SEGINI PRMI
  343.          CALL ISETI(PRMI.LECT,NTTINC)
  344.          PRM.ML(IINC)=PRMI
  345.          NNUI=NNU.ML(IINC)
  346.          CALL ISHELI(NTTINC,PRMI.LECT,NTTINC,NNUI.LECT,
  347.      $        IMPR,IRET)
  348.          IF (IRET.NE.0) GOTO 9999
  349.       ENDDO
  350. C      SEGPRT,PRM
  351. C      DO IORD=1,NORD
  352. C         PRMI=PRM.ML(IORD)
  353. C         SEGPRT,PRMI
  354. C      ENDDO
  355. *
  356. * 3 En "merge"ant les listes précédentes, on obtient
  357. *   la permutation réciproque de la nouvelle numérotation
  358. *   totale que l'on cherche (si, si !)
  359. *
  360.       JG=NTTDDL
  361.       SEGINI PRMDDL
  362.       JG=NINC
  363.       SEGINI ITTDDL
  364.       DO IINC=1,NINC
  365.          ITTDDL.LECT(IINC)=1
  366.       ENDDO
  367.       JG=NINC
  368.       SEGINI DDLOK
  369.       DO IINC=1,NINC
  370.          DDLOK.LOGI(IINC)=(ITTDDL.LECT(IINC).LE.DDLDIM.LECT(IINC))
  371.       ENDDO
  372.       JG=NINC
  373.       SEGINI INUDDL
  374.       DO IINC=1,NINC
  375.          IF (DDLOK.LOGI(IINC)) THEN
  376.             NNUI=NNU.ML(IINC)
  377.             PRMI=PRM.ML(IINC)
  378. *               IITT=ITTDDL.LECT(IORD)
  379. *               IPRM=PRM1.LECT(IITT)
  380. *               INNU=NNU1.LECT(IPRM)
  381.             INUDDL.LECT(IINC)=NNUI.LECT(PRMI.LECT(ITTDDL.LECT(IINC)))
  382.          ENDIF
  383.       ENDDO
  384.       DO JTTDDL=1,NTTDDL
  385.          JNUMIN=0
  386.          JINC=0
  387.          DO IINC=1,NINC
  388.             IF (DDLOK.LOGI(IINC)) THEN
  389.                IF (JNUMIN.EQ.0) THEN
  390.                   JNUMIN=INUDDL.LECT(IINC)
  391.                   JINC=IINC
  392.                ELSE
  393.                   KNUMIN=INUDDL.LECT(IINC)
  394.                   IF (KNUMIN.LT.JNUMIN) THEN
  395.                      JNUMIN=KNUMIN
  396.                      JINC=IINC
  397.                   ENDIF
  398.                ENDIF
  399.             ENDIF
  400.          ENDDO
  401.          IF ((JNUMIN.EQ.0).OR.(JINC.EQ.0)) THEN
  402.             WRITE(IOIMP,*) 'Erreur trop grave 2'
  403.             GOTO 9999
  404.          ENDIF
  405.          LDDI=LDD.ML(JINC)
  406.          NNUI=NNU.ML(JINC)
  407.          PRMI=PRM.ML(JINC)
  408.          KTTDDL=ITTDDL.LECT(JINC)
  409.          PRMDDL.LECT(JTTDDL)=LDDI.LECT(PRMI.LECT(KTTDDL))
  410.          ITTDDL.LECT(JINC)=KTTDDL+1
  411.          DDLOK.LOGI(JINC)=(ITTDDL.LECT(JINC).LE.DDLDIM.LECT(JINC))
  412.          IF (DDLOK.LOGI(JINC)) THEN
  413.             NNUI=NNU.ML(JINC)
  414.             PRMI=PRM.ML(JINC)
  415.             INUDDL.LECT(JINC)=NNUI.LECT(PRMI.LECT(ITTDDL.LECT(JINC)))
  416.          ENDIF
  417.       ENDDO
  418.       SEGSUP INUDDL
  419.       SEGSUP DDLOK
  420.       SEGSUP ITTDDL
  421.       DO IINC=1,NINC
  422.          PRMI=PRM.ML(IINC)
  423.          SEGSUP PRMI
  424.       ENDDO
  425.       SEGSUP PRM
  426.       DO IINC=1,NINC
  427.          NNUI=NNU.ML(IINC)
  428.          SEGSUP NNUI
  429.       ENDDO
  430.       SEGSUP NNU
  431.       SEGSUP DDLDIM
  432.       DO IINC=1,NINC
  433.          LDDI=LDD.ML(IINC)
  434.          SEGSUP LDDI
  435.       ENDDO
  436.       SEGSUP LDD
  437. *      SEGPRT,PRMDDL
  438. *
  439. * D'où la nouvelle numérotation :
  440. *
  441.       JG=NTTDDL
  442.       SEGINI NEWNUM
  443.       CALL RSETXI(NEWNUM.LECT,PRMDDL.LECT,NTTDDL)
  444.       SEGDES NEWNUM
  445.       SEGSUP PRMDDL
  446. *STAT         CALL PRMSTA('    Merge et obtention NEWNUM',MSTAT,IMPR)
  447. *      SEGPRT,NEWNUM
  448. *      STOP 16
  449. *
  450. * Normal termination
  451. *
  452.       IRET=0
  453.       RETURN
  454. *
  455. * Format handling
  456. *
  457. *
  458. * Error handling
  459. *
  460.  9999 CONTINUE
  461.       IRET=1
  462.       WRITE(IOIMP,*) 'An error was detected in subroutine calnu4'
  463.       RETURN
  464. *
  465. * End of subroutine CALNU4
  466. *
  467.       END
  468.  
  469.  
  470.  
  471.  
  472.  
  473.  
  474.  
  475.  
  476.  
  477.  
  478.  

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