Télécharger la plaquette Cast3M


fr en

Télécharger mkizt2.eso

Retour à la liste

Numérotation des lignes : 

mkizt2

  1. C MKIZT2    SOURCE    PV        20/09/26    21:18:55     10724          
  2.       SUBROUTINE MKIZT2(MELDUA,MELPRI,IMATEL,
  3.      $     KRINCD,KRINCP,KMINCT,KRSPGT,
  4.      $     PMTOT,IDMATP,IDMATD,
  5. *IDMTOT,
  6.      $     IZATOT,
  7.      $     IMPR,IRET)
  8.       IMPLICIT REAL*8 (A-H,O-Z)
  9.       IMPLICIT INTEGER (I-N)
  10. C***********************************************************************
  11. C NOM         : MKIZT2
  12. C DESCRIPTION : Pareil que mkizat + changement de numérotation (argument
  13. C               d'entrée)
  14. C               Remplissage des valeurs de la Matrice Morse.
  15. C               (dont les colonnes sont supposées ordonnées)
  16. C               quasiment identique à mkiza.
  17. C               pareil que mkizat avec changement de numérotation
  18. C               (IDMTOT.NUAN)
  19. C
  20. C LANGAGE     : ESOPE
  21. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  22. C               mél : gounand@semt2.smts.cea.fr
  23. C***********************************************************************
  24. C APPELES          : REGMAI, IFIDIC, INIRPM
  25. C APPELE PAR       : PRASEM
  26. C***********************************************************************
  27. C ENTREES            : MELDUA, MELPRI, IMATEL, KRINCD, KRINCP, KMINCT,
  28. C                      KRSPGT, PMTOT, IDMTOT
  29. C ENTREES/SORTIES    : IZATOT
  30. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  31. C***********************************************************************
  32. C VERSION    : v1, 16/12/99
  33. C HISTORIQUE : v1, 16/12/99, création
  34. C HISTORIQUE : 05/01/00 : On ne suppose plus les maillages duaux et
  35. C      primaux partitionnés de la même façon que les matrices
  36. C      élémentaires.
  37. C HISTORIQUE : 09/04/04 ajout idmatp idmatd
  38. C HISTORIQUE :
  39. C***********************************************************************
  40. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  41. C en cas de modification de ce sous-programme afin de faciliter
  42. C la maintenance !
  43. C***********************************************************************
  44. -INC PPARAM
  45. -INC CCOPTIO
  46. -INC SMELEME
  47.       POINTEUR MELDUA.MELEME
  48.       POINTEUR ML2DUA.MELEME
  49.       POINTEUR SMLDUA.MELEME
  50.       POINTEUR MELPRI.MELEME
  51.       POINTEUR ML2PRI.MELEME
  52.       POINTEUR SMLPRI.MELEME
  54.       POINTEUR IMATEL.IMATRI
  55.       POINTEUR VMATEL.IZAFM
  56.       POINTEUR KMINCT.MINC
  57.       POINTEUR PMTOT.PMORS
  58.       POINTEUR IZATOT.IZA
  59. *      POINTEUR IDMTOT.IDMAT
  60.       POINTEUR IDMATP.IDMAT
  61.       POINTEUR IDMATD.IDMAT
  62. -INC SMLENTI
  63.       POINTEUR KRINCD.MLENTI
  64.       POINTEUR KRINCP.MLENTI
  65.       POINTEUR KRSPGT.MLENTI
  66.       POINTEUR RPMAT.MLENTI
  67. *
  68.       INTEGER IMPR,IRET
  69. *
  70.       LOGICAL LPARTD,LPARTP
  71.       INTEGER IDX,IDXDEB
  72.       INTEGER ISOUM,NBSOUM,NBSOUD,NBSOUP
  73.       INTEGER ITDDLD,ITDDLP,ITIDUA,ITIPRI,ITPODU,ITPOPR
  74.       INTEGER NBCMPD,NBCMPP,NELPRI
  75.       INTEGER ILMAT,JDMAT,IPMAT,IMATL
  76.       INTEGER NLMAT,NDMAT,NPMAT,NBMATL
  77.       INTEGER LONLIG
  78.       INTEGER IELEM
  79.       INTEGER NUELG,OLDISM,ISOUMA,NUELOC
  80. *
  81. * Executable statements
  82. *
  83.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mkizt2'
  84. * On régularise les maillage pour plus se faire chier si LISOUS(/1).EQ.0
  85. * In REGMAI : IF (.NOT.LPARTD) SEGINI ML2DUA
  86.       CALL REGMAI(MELDUA,ML2DUA,LPARTD,IMPR,IRET)
  87.       IF (IRET.NE.0) GOTO 9999
  88. * In REGMAI : IF (.NOT.LPARTP) SEGINI ML2PRI
  89.       CALL REGMAI(MELPRI,ML2PRI,LPARTP,IMPR,IRET)
  90.       IF (IRET.NE.0) GOTO 9999
  91. *
  92. * Activons les chapeaux (Matrices et supports)
  93. *
  94.       SEGACT ML2DUA
  95.       NBSOUD=ML2DUA.LISOUS(/1)
  96.       SEGACT ML2PRI
  97.       NBSOUP=ML2PRI.LISOUS(/1)
  98.       SEGACT IMATEL
  99.       NBSOUM=NBSOUP
  100.       NBMATL=IMATEL.LIZAFM(/2)
  101.       IF (NBSOUD.NE.NBSOUP) THEN
  102.          WRITE(IOIMP,*) 'Maillage primal, dual :'
  103.          WRITE(IOIMP,*) 'partitionnment différent...'
  104.          WRITE(IOIMP,*) 'NBSOUD=',NBSOUD
  105.          WRITE(IOIMP,*) 'NBSOUP=',NBSOUP
  106.          GOTO 9999
  107.       ENDIF
  108. *
  109. * Tableau de repérage dans la matrice
  110. *
  111. * In INIRPM : SEGINI RPMAT
  112.       CALL INIRPM(IMATEL,RPMAT,IMPR,IRET)
  113.       IF (IRET.NE.0) GOTO 9999
  114. *
  115. * Activons les tableaux de repérage
  116. *
  117.       SEGACT KRINCD
  118.       NBCMPD=KRINCD.LECT(/1)
  119.       SEGACT KRINCP
  120.       NBCMPP=KRINCP.LECT(/1)
  121.       IF (NBCMPD.NE.NBMATL.OR.NBCMPP.NE.NBMATL) THEN
  122.          WRITE(IOIMP,*) 'KRINCD, KRINCP et IMATEL :'
  123.          WRITE(IOIMP,*) 'nb. comp. différents...'
  124.          GOTO 9999
  125.       ENDIF
  126.       SEGACT KMINCT
  127.       SEGACT KRSPGT
  128.       SEGACT PMTOT
  129. *      SEGACT IDMTOT
  130.       SEGACT IDMATP
  131.       SEGACT IDMATD
  132.       SEGACT IZATOT*MOD
  133. *
  134. * Parcourons les matrices élémentaires par sous-domaine et
  135. * remplissons les valeurs de la matrice Morse.
  136. *
  137.       DO 1 IMATL=1,NBMATL
  138.          ITIDUA=KRINCD.LECT(IMATL)
  139.          ITIPRI=KRINCP.LECT(IMATL)
  140.          NUELG=0
  141.          OLDISM=1
  142.          VMATEL=IMATEL.LIZAFM(OLDISM,IMATL)
  143.          SEGACT VMATEL
  144.          DO 12 ISOUM=1,NBSOUM
  145.             SMLDUA=ML2DUA.LISOUS(ISOUM)
  146.             SEGACT SMLDUA
  147.             SMLPRI=ML2PRI.LISOUS(ISOUM)
  148.             SEGACT SMLPRI
  149.             NELPRI=SMLPRI.NUM(/2)
  150.             DO 122 IELEM=1,NELPRI
  151.                NUELG=NUELG+1
  152.                CALL RPELEM(NUELG,RPMAT,ISOUMA,NUELOC,IMPR,IRET)
  153.                IF (IRET.NE.0) GOTO 9999
  154.                ISOUMA=MAX(ISOUMA,1)
  155.                IF (ISOUMA.NE.OLDISM) THEN
  156.                   SEGDES VMATEL
  157.                   VMATEL=IMATEL.LIZAFM(ISOUMA,IMATL)
  158.                   SEGACT VMATEL
  159.                   OLDISM=ISOUMA
  160.                ENDIF
  161.                ILMAT=NUELOC
  162.                NPMAT=VMATEL.AM(/2)
  163.                NDMAT=VMATEL.AM(/3)
  164.                DO 1222 JDMAT=1,NDMAT
  165.                   ITPODU=KRSPGT.LECT(SMLDUA.NUM(JDMAT,IELEM))
  166.                   IF (ITPODU.EQ.0) THEN
  167.                      WRITE(IOIMP,*) 'Point dual ????'
  168.                      GOTO 9999
  169.                   ENDIF
  170. C     Test du MPOS... déjà fait dans mkpmor...
  171.                   ITDDLD=IDMATD.NUAN(
  172.      $                 KMINCT.NPOS(ITPODU)
  173.      $                 + KMINCT.MPOS(ITPODU,ITIDUA)-1
  174.      $                 )
  175. C     IPMAT parce que IDMAT est le nom d'un segment par défaut...
  176.                   DO 12222 IPMAT=1,NPMAT
  177.                      ITPOPR=KRSPGT.LECT(SMLPRI.NUM(IPMAT,IELEM))
  178.                      IF (ITPOPR.EQ.0) THEN
  179.                         WRITE(IOIMP,*) 'Point primal ????'
  180.                         GOTO 9999
  181.                      ENDIF
  182.                      ITDDLP=IDMATP.NUAN(
  183.      $                    KMINCT.NPOS(ITPOPR)
  184.      $                    + KMINCT.MPOS(ITPOPR,ITIPRI)-1
  185.      $                    )
  186.                      IDXDEB=PMTOT.IA(ITDDLP)
  187.                      LONLIG=PMTOT.IA(ITDDLP+1)-IDXDEB
  188.                      IF (LONLIG.EQ.0) THEN
  189.                         WRITE(IOIMP,*) 'Ligne inex. ddl pri =',ITDDLP
  190.                         GOTO 9999
  191.                      ENDIF
  192.                      CALL IFIDIC(LONLIG,PMTOT.JA(IDXDEB),ITDDLD,
  193.      $                    IDX,
  194.      $                    IMPR,IRET)
  195.                      IF (IRET.NE.0) GOTO 9999
  196.                      IZATOT.A(IDXDEB+IDX-1)=IZATOT.A(IDXDEB+IDX-1)
  197.      $                    + VMATEL.AM(ILMAT,IPMAT,JDMAT)
  198. 12222             CONTINUE
  199.  1222          CONTINUE
  200.  122        CONTINUE
  201.             SEGDES VMATEL
  202.  12      CONTINUE
  203.          SEGDES SMLPRI
  204.          SEGDES SMLDUA
  205.  1    CONTINUE
  206.       SEGDES IZATOT
  207.       SEGDES IDMATD
  208.       SEGDES IDMATP
  209. *      SEGDES IDMTOT
  210.       SEGDES PMTOT
  211.       SEGDES KRSPGT
  212.       SEGDES KMINCT
  213.       SEGDES KRINCP
  214.       SEGDES KRINCD
  215.       SEGSUP RPMAT
  216.       SEGDES IMATEL
  217.       SEGDES ML2PRI
  218.       SEGDES ML2DUA
  219.       IF (.NOT.LPARTP) SEGSUP ML2PRI
  220.       IF (.NOT.LPARTD) SEGSUP ML2DUA
  221. *
  222. * Normal termination
  223. *
  224.       IRET=0
  225.       RETURN
  226. *
  227. * Format handling
  228. *
  229. *
  230. * Error handling
  231. *
  232.  9999 CONTINUE
  233.       IRET=1
  234.       WRITE(IOIMP,*) 'An error was detected in subroutine mkizt2'
  235.       RETURN
  236. *
  237. * End of subroutine MKIZT2
  238. *
  239.       END
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  

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