Télécharger la plaquette Cast3M


fr en

Télécharger cv2mab.eso

Retour à la liste

Numérotation des lignes : 

cv2mab

  1. C CV2MAB    SOURCE    GOUNAND   24/11/06    21:15:05     12073          
  2.       SUBROUTINE CV2MAB(CGEOMQ,MDISCP,NCVARP,MDISCD,NCVARD,
  3.      $     IMTLSB,
  4.      $     MYFALS,
  5.      $     MATLSB,
  6.      $     IMPR,IRET)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8.       IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM         : CV2MAB
  11. C DESCRIPTION : Transforme un MCHAEL (mon champ par éléments)
  12. C               représentant un ensemble de matrices élémentaires en
  13. C               MATRIK...
  14. C
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C               mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES          : KEEF   (recherche de l'élément fini)
  20. C APPELES (E/S)    : ECROBJ, PRLIST (écriture entier, objet,
  21. C                    impression)
  22. C APPELE PAR       : PRLSB2
  23. C***********************************************************************
  24. C ENTREES            :
  25. C ENTREES/SORTIES    : -
  26. C SORTIES            :
  27. C TRAVAIL            : * MYMEL (type MELEME) : maillage élémentaire.
  28. C                      * JMTLSB (type MCHEVA) : valeurs du champ IMTLSB
  29. C                        sur le maillage élémentaire.
  30. C                        Structure (cf.include SMCHAEL) :
  31. C                        (nb. ddl dual, nb. ddl primal,
  32. C                         nb. comp. duales, nb. comp. primales,
  33. C                         1, nb. éléments)
  34. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  35. C***********************************************************************
  36. C VERSION    : v1, 22/07/09, version initiale
  37. C HISTORIQUE : v1, 22/07/09, création
  38. C HISTORIQUE :
  39. C HISTORIQUE :
  40. C***********************************************************************
  41. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  42. C en cas de modification de ce sous-programme afin de faciliter
  43. C la maintenance !
  44. C***********************************************************************
  45.  
  46. -INC PPARAM
  47. -INC CCOPTIO
  48. -INC SMLMOTS
  49.       POINTEUR NCVARP.MLMOTS
  50.       POINTEUR NCVARD.MLMOTS
  51. -INC SMELEME
  52.       POINTEUR CGEOMQ.MELEME
  53.       POINTEUR MELPRI.MELEME
  54.       POINTEUR MELDUA.MELEME
  55.       POINTEUR MYMEL.MELEME
  56.       INTEGER NBNN,NBELEM,NBSOUS,NBREF
  57. -INC SMLENTI
  58.       POINTEUR LPOQFP.MLENTI
  59.       POINTEUR LPOQFD.MLENTI
  60.       POINTEUR KPOQFP.MLENTI
  61.       POINTEUR KPOQFD.MLENTI
  62.       INTEGER JG
  64.       POINTEUR MATLSB.MATRIK
  65. *
  66. * Includes persos
  67. *
  68. -INC TNLIN
  69. *-INC SMCHAEL
  70.       POINTEUR IMTLSB.MCHAEL
  71.       POINTEUR JMTLSB.MCHEVA
  72.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  73. *-INC SFALRF
  74.       POINTEUR MYFALS.FALRFS
  75. *-INC SELREF
  76.       POINTEUR LRFPRI.ELREF
  77.       POINTEUR LRFDUA.ELREF
  78. *
  79.       CHARACTER*4 MDISCP,MDISCD
  80.       INTEGER IMPR,IRET
  81. *
  82.       INTEGER IBNN,IBELEM
  83.       INTEGER ITQUAF,NDDLPR,NDDLDU
  84.       INTEGER        IDDLPR,IDDLDU
  85.       INTEGER               NSOUS,NPOQUF
  86.       INTEGER ISOUS
  87.       INTEGER ILIGRP,ILIGRD,IELRIG,ICMPP,ICMPD
  88.  
  89. *
  90. * Executable statements
  91. *
  92.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cv2mab'
  93.       NRIGE=7
  94.       NMATRI=0
  95.       NKID=9
  96.       NKMT=7
  97.       SEGINI,MATLSB
  98. *
  99. *     Remplissage de MRIGID
  100. *
  101.       SEGACT NCVARP
  102.       SEGACT NCVARD
  103.       SEGACT IMTLSB
  104.       NSOUS=IMTLSB.JMACHE(/1)
  105. C     SEGPRT,NCVARP
  106. C     SEGPRT,NCVARD
  107. C     SEGPRT,IMTLSB
  108.       SEGACT CGEOMQ
  109.       DO ISOUS=1,NSOUS
  110.          JMTLSB=IMTLSB.ICHEVA(ISOUS)
  111.          IF (JMTLSB.NE.0) THEN
  112. C            SEGPRT,NCVARP
  113. C            SEGPRT,NCVARD
  114. C            SEGPRT,JMTLSB
  115.             SEGACT JMTLSB
  116.             MYMEL =CGEOMQ.LISOUS(ISOUS)
  117.             SEGACT MYMEL
  118.             ITQUAF=MYMEL.ITYPEL
  119.             CALL KEEF(ITQUAF,MDISCP,MYFALS,
  120.      $           LRFPRI,IMPR,IRET)
  121.             IF (IRET.NE.0) GOTO 9999
  122.             SEGACT LRFPRI
  123.             NDDLPR=LRFPRI.NPQUAF(/1)
  124.             CALL KEEF(ITQUAF,MDISCD,MYFALS,
  125.      $           LRFDUA,IMPR,IRET)
  126.             IF (IRET.NE.0) GOTO 9999
  127.             SEGACT LRFDUA
  128.             NDDLDU=LRFDUA.NPQUAF(/1)
  129. * Si le maillage donné à NLIN n'était pas QUAF au départ, il faut
  130. * vérifier que tous les ddls peuvent s'appuyer sur les points du
  131. * maillage donné
  132. * Le test uniquement sur le 1er element doit etre suffisant
  133.             IF (CGEOMQ.LISOUS(ISOUS).NE.0) THEN
  134.                DO IDDLPR=1,NDDLPR
  135.                   NNQUA=LRFPRI.NPQUAF(IDDLPR)
  136.                   NNGLO=MYMEL.NUM(NNQUA,1)
  137.                   IF (NNGLO.EQ.0) THEN
  138.                      WRITE(IOIMP,*) 'A discretization space ',MDISCP,
  139.      $                    ' is incompatible with the given mesh'
  140.                      WRITE(IOIMP,*) 'Check its element type please'
  141.                      GOTO 9999
  142.                   ENDIF
  143.                ENDDO
  144.                DO IDDLDU=1,NDDLDU
  145.                   NNQUA=LRFDUA.NPQUAF(IDDLDU)
  146.                   NNGLO=MYMEL.NUM(NNQUA,1)
  147.                   IF (NNGLO.EQ.0) THEN
  148.                      WRITE(IOIMP,*) 'A discretization space ',MDISCD,
  149.      $                    ' is incompatible with the given mesh'
  150.                      WRITE(IOIMP,*) 'Check its element type please'
  151.                      GOTO 9999
  152.                   ENDIF
  153.                ENDDO
  154.             ENDIF
  155. *
  156.            DO IVARP=1,NCVARP.MOTS(/2)
  157. *  Construction de la liste des points du QUAF sur lesquels il y a des
  158. *  ddl pour l'inconnue primale
  159.                JG=0
  160.                SEGINI LPOQFP
  161.                DO IDDLPR=1,NDDLPR
  162.                   IF (LRFPRI.NUMCMP(IDDLPR).EQ.IVARP) THEN
  163.                      LPOQFP.LECT(**)=LRFPRI.NPQUAF(IDDLPR)
  164.                   ENDIF
  165.                ENDDO
  166.                IF (LPOQFP.LECT(/1).EQ.0) THEN
  167.                   GOTO 1
  168.                ENDIF
  169. C*  Suppression des doublons (pas besoin)
  170. C               CALL IUNIQ(LPOQFP.LECT,LPOQFP.LECT(/1),
  171. C     $           LPOQFP.LECT,NPOQFP,
  172. C     $              IMPR,IRET)
  173. C               IF (IRET.NE.0) GOTO 9999
  174. C               JG=NPOQFP
  175. C               SEGADJ,LPOQFP
  176. * Segment de repérage dans cette liste
  177.                JG=MYMEL.NUM(/1)
  178.                SEGINI,KPOQFP
  179.                CALL RSETXI(KPOQFP.LECT,LPOQFP.LECT,LPOQFP.LECT(/1))
  180. * Construction du maillage primal
  181.                NBNN=LPOQFP.LECT(/1)
  182.                NBELEM = MYMEL.NUM(/2)
  183.                NBSOUS = 0
  184.                NBREF=0
  185.                SEGINI,MELPRI
  186. * Type 32 POLY
  187.                MELPRI.ITYPEL=32
  188.                DO IBELEM=1,NBELEM
  189.                   DO IBNN=1,NBNN
  190.                      MELPRI.NUM(IBNN,IBELEM)=
  191.      $                    MYMEL.NUM(LPOQFP.LECT(IBNN),IBELEM)
  192.                   ENDDO
  193.                ENDDO
  194.                SEGDES MELPRI
  195. *
  196.                DO IVARD=1,NCVARD.MOTS(/2)
  197. *  Construction de la liste des points du QUAF sur lesquels il y a des
  198. *  ddl pour l'inconnue duale
  199.                   JG=0
  200.                   SEGINI LPOQFD
  201.                   DO IDDLDU=1,NDDLDU
  202.                      IF (LRFDUA.NUMCMP(IDDLDU).EQ.IVARD) THEN
  203.                         LPOQFD.LECT(**)=LRFDUA.NPQUAF(IDDLDU)
  204.                      ENDIF
  205.                   ENDDO
  206.                   IF (LPOQFD.LECT(/1).EQ.0) THEN
  207.                      GOTO 3
  208.                   ENDIF
  209. C*  Suppression des doublons
  210. C                  CALL IUNIQ(LPOQFD.LECT,LPOQFD.LECT(/1),
  211. C     $                 LPOQFD.LECT,NPOQFD,
  212. C     $                 IMPR,IRET)
  213. C                  IF (IRET.NE.0) GOTO 9999
  214. C                  JG=NPOQFD
  215. C                  SEGADJ,LPOQFD
  216. * Segment de repérage dans cette liste
  217.                   JG=MYMEL.NUM(/1)
  218.                   SEGINI,KPOQFD
  219.                   CALL RSETXI(KPOQFD.LECT,LPOQFD.LECT,LPOQFD.LECT(/1))
  220. * Construction du maillage dual
  221.                   NBNN=LPOQFD.LECT(/1)
  222.                   NBELEM = MYMEL.NUM(/2)
  223.                   NBSOUS = 0
  224.                   NBREF=0
  225.                   SEGINI,MELDUA
  226. * Type 32 POLY
  227.                   MELDUA.ITYPEL=32
  228.                   DO IBELEM=1,NBELEM
  229.                      DO IBNN=1,NBNN
  230.                         MELDUA.NUM(IBNN,IBELEM)=
  231.      $                       MYMEL.NUM(LPOQFD.LECT(IBNN),IBELEM)
  232.                      ENDDO
  233.                   ENDDO
  234.                   SEGDES MELDUA
  235. * Construction du IMATRI
  236.                   NBME=1
  237.                   NBSOUS=1
  238.                   SEGINI IMATRI
  239.                   LISPRI(1)=NCVARP.MOTS(IVARP)
  240.                   LISDUA(1)=NCVARD.MOTS(IVARD)
  241. * Construction du IZAFM
  242.                   NBEL=MYMEL.NUM(/2)
  243.                   NP=LPOQFP.LECT(/1)
  244.                   MP=LPOQFD.LECT(/1)
  245.                   SEGINI IZAFM
  246. * remplissage des matrices élémentaires
  247.                   NBLIG=JMTLSB.WELCHE(/1)
  248.                   NBCOL=JMTLSB.WELCHE(/2)
  249.                   N2LIG=JMTLSB.WELCHE(/3)
  250.                   N2COL=JMTLSB.WELCHE(/4)
  251.                   NBPOI=JMTLSB.WELCHE(/5)
  252.                   NBELM=JMTLSB.WELCHE(/6)
  253.                   IF (NBLIG.NE.NDDLDU.OR.NBCOL.NE.NDDLPR.OR.N2LIG.NE.1
  254.      $                 .OR.N2COL.NE.1.OR.NBPOI.NE.1.OR.NBELM.NE.NBEL)
  255.      $                 THEN
  256.                      WRITE(IOIMP,*) 'Erreur dims JMTLSB'
  257.                      GOTO 9999
  258.                   ENDIF
  259.                   DO IDDLDU=1,NDDLDU
  260.                      IF (LRFDUA.NUMCMP(IDDLDU).EQ.IVARD) THEN
  261.                         IMP=KPOQFD.LECT(LRFDUA.NPQUAF(IDDLDU))
  262.                         DO IDDLPR=1,NDDLPR
  263.                            IF (LRFPRI.NUMCMP(IDDLPR).EQ.IVARP) THEN
  264.                               INP=KPOQFP.LECT(LRFPRI.NPQUAF(IDDLPR))
  265.                               DO IBEL=1,NBEL
  266.                                  AM(IBEL,INP,IMP)=
  267.      $                                JMTLSB.WELCHE(IDDLDU,IDDLPR,
  268.      $                                1,1,1,IBEL)
  269.                               ENDDO
  270.                            ENDIF
  271.                         ENDDO
  272.                      ENDIF
  273.                   ENDDO
  274.                   SEGDES IZAFM
  275.                   LIZAFM(1,1)=IZAFM
  276.                   SEGDES IMATRI
  277. *
  278. * Remplissage du chapeau
  279. *
  280.                   NRIGE=MATLSB.IRIGEL(/1)
  281.                   NMATRI=MATLSB.IRIGEL(/2)+1
  282.                   NKID=MATLSB.KIDMAT(/1)
  283.                   NKMT=MATLSB.KKMMT(/1)
  284.                   SEGADJ,MATLSB
  285.                   MATLSB.IRIGEL(1,NMATRI)=MELPRI
  286.                   MATLSB.IRIGEL(2,NMATRI)=MELDUA
  287.                   MATLSB.IRIGEL(4,NMATRI)=IMATRI
  288.                   MATLSB.IRIGEL(7,NMATRI)=2
  289.                   SEGSUP KPOQFD
  290.  3                CONTINUE
  291.                   SEGSUP LPOQFD
  292.                ENDDO
  293.                SEGSUP KPOQFP
  294.  1             CONTINUE
  295.                SEGSUP LPOQFP
  296.             ENDDO
  297.             SEGDES LRFDUA
  298.             SEGDES LRFPRI
  299.             SEGDES MYMEL
  300.             SEGDES JMTLSB
  301.          ENDIF
  302.       ENDDO
  303.       SEGDES IMTLSB
  304.       SEGDES NCVARD
  305.       SEGDES NCVARP
  306.       SEGDES MATLSB
  307.       IF (IMPR.GT.3) THEN
  308.          WRITE(IOIMP,*) 'On a créé MATLSB=',MATLSB
  309.          CALL ECROBJ('MATRIK  ',MATLSB)
  310.          CALL PRLIST
  311.       ENDIF
  312. *
  313. * Normal termination
  314. *
  315.       IRET=0
  316.       RETURN
  317. *
  318. * Format handling
  319. *
  320. *
  321. * Error handling
  322. *
  323.  9999 CONTINUE
  324.       IRET=1
  325.       WRITE(IOIMP,*) 'An error was detected in subroutine cv2mab'
  326.       RETURN
  327. *
  328. * End of subroutine CV2MAB
  329. *
  330.       END
  331.  
  332.  

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