Télécharger la plaquette Cast3M


fr en

Télécharger cv2ma9.eso

Retour à la liste

Numérotation des lignes : 

cv2ma9

  1. C CV2MA9    SOURCE    CB215821  25/04/23    21:15:12     12247          
  2.       SUBROUTINE CV2MA9(CGEOMQ,MDISCP,NCVARP,MDISCD,NCVARD,
  3.      $     IMTLS9,
  4.      $     MYFALS,
  5.      $     MATLS9,
  6.      $     IMPR,IRET)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8.       IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM         : CV2MA9
  11. C DESCRIPTION : Transforme un MCHAEL (mon champ par éléments)
  12. C               représentant un ensemble de matrices élémentaires en
  13. C               RIGIDITE...
  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       : PRLS92
  23. C***********************************************************************
  24. C ENTREES            :
  25. C ENTREES/SORTIES    : -
  26. C SORTIES            :
  27. C TRAVAIL            : * MYMEL (type MELEME) : maillage élémentaire.
  28. C                      * JMTLS9 (type MCHEVA) : valeurs du champ IMTLS9
  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, 26/09/03, version initiale
  37. C HISTORIQUE : v1, 26/09/03, création
  38. C HISTORIQUE :     25/10/2024 : au lieu de creer de nouveaux MELEME
  39. C                           on utilise celui fourni en entrée de NLIN.
  40. C HISTORIQUE :
  41. C***********************************************************************
  42. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  43. C en cas de modification de ce sous-programme afin de faciliter
  44. C la maintenance !
  45. C***********************************************************************
  46. -INC PPARAM
  47. -INC CCOPTIO
  48. -INC CCGEOME
  49. -INC CCHAMP
  50. -INC SMLMOTS
  51.       POINTEUR NCVARP.MLMOTS
  52.       POINTEUR NCVARD.MLMOTS
  53. -INC SMELEME
  54.       POINTEUR CGEOMQ.MELEME
  55.       POINTEUR MELEMQ.MELEME
  56. -INC SMLENTI
  57.       POINTEUR IGEO.MLENTI
  58. -INC SMRIGID
  59. -INC SMCOORD
  60.       POINTEUR MATLS9.MRIGID
  61.       POINTEUR MYDSCR.DESCR
  62.       POINTEUR MYIMAT.IMATRI
  63.       POINTEUR MYXMAT.XMATRI
  64. *
  65. * Includes persos
  66. *
  67. -INC TNLIN
  68. *-INC SMCHAEL
  69.       POINTEUR IMTLS9.MCHAEL
  70.       POINTEUR JMTLS9.MCHEVA
  71.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  72. *-INC SFALRF
  73.       POINTEUR MYFALS.FALRFS
  74. *-INC SELREF
  75.       POINTEUR LRFPRI.ELREF
  76.       POINTEUR LRFDUA.ELREF
  77.       POINTEUR LRFGEO.ELREF
  78. *
  79.       CHARACTER*(LOCHPO) NOMINP,NOMIND,nominpd
  80.       CHARACTER*4 MDISCP,MDISCD,MDISCG
  81.       INTEGER IMPR,IRET
  82. *
  83.       INTEGER ITQUAF,NDDLPR,NDDLDU
  84.       INTEGER        IDDLPR,IDDLDU
  85.       INTEGER               NSOUS,NPOQUF
  86.       INTEGER ISOUS
  87.       INTEGER ILIGRP,ILIGRD,IELRIG,ICMPP,ICMPD
  88.       LOGICAL LQUAF,LSYM
  89. *
  90. * Executable statements
  91. *
  92.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cv2ma9'
  93.       NRIGEL=0
  94.       SEGINI,MATLS9
  95.       MATLS9.MTYMAT='LEASTSQU'
  96.       MATLS9.IFORIG=IFOUR
  97. *     On prend le mode de calcul courant (on pourrait s'appuyer sur
  98. *     celui du champ ?)
  99. *Test LSYM=.FALSE.
  100.       LSYM=MDISCP.EQ.MDISCD
  101. *      write(ioimp,*) 'lsym1=',lsym
  102. *
  103. *     Remplissage de MRIGID
  104. *
  105.       SEGACT NCVARP
  106.       SEGACT NCVARD
  107. *
  108.       IF (LSYM) THEN
  109.          nvar=ncvarp.mots(/2)
  110.          lsym=lsym.and.(nvar.eq.ncvard.mots(/2))
  111. *         write(ioimp,*) 'lsym1.5=',lsym
  112.          do ivar=1,nvar
  113.             if (lsym) then
  114.                nominp=ncvarp.mots(ivar)
  115.                nomind=ncvard.mots(ivar)
  116.                call place(nomdd,lnomdd,idxp,nominp)
  117.                if (idxp.ne.0) then
  118.                   nominpd=nomdu(idxp)
  119.                   lsym=lsym.and.(nominpd.eq.nomind)
  120.                else
  121.                   lsym=lsym.and.(nominp.eq.nomind)
  122.                endif
  123.             else
  124.                goto 11
  125.             endif
  126.          enddo
  127.  11      continue
  128.       ENDIF
  129. *      write(ioimp,*) 'lsym2=',lsym
  130.  
  131.       SEGACT IMTLS9
  132.       NSOUS=IMTLS9.JMACHE(/1)
  133.       SEGACT CGEOMQ
  134.       DO ISOUS=1,NSOUS
  135.          JMTLS9=IMTLS9.ICHEVA(ISOUS)
  136.          IF (JMTLS9.NE.0) THEN
  137.             MELEMQ=CGEOMQ.LISOUS(ISOUS)
  138.             SEGACT MELEMQ
  139.             ITQUAF=MELEMQ.ITYPEL
  140.             LQUAF=(CGEOMQ.LISREF(ISOUS).EQ.0)
  141.             IF (LQUAF) THEN
  142.                MELEME=MELEMQ
  143.             ELSE
  144.                MELEME=CGEOMQ.LISREF(ISOUS)
  145.                SEGACT MELEME
  146.                CALL IDQUDI(ITYPEL,ITQUA2,MDISCG)
  147.                IF (IERR.NE.0) GOTO 9999
  148.                IF (ITQUA2.NE.ITQUAF) THEN
  149.                   WRITE(IOIMP,*) 'ITQUA2=',ITQUA2
  150.                   WRITE(IOIMP,*) 'ITQUAF=',ITQUAF
  151.                   CALL ERREUR(5)
  152.                   GOTO 9999
  153.                ENDIF
  154.                CALL KEEF(ITQUAF,MDISCG,MYFALS,
  155.      $              LRFGEO,IMPR,IRET)
  156.                IF (IRET.NE.0) GOTO 9999
  157.                SEGACT LRFGEO
  158. *     Tableau de correspondance Noeud du QUAF -> Noeud de l'element
  159. *     GEOmetrique
  160.                JG=NBNNE(ITQUAF)
  161.                SEGINI IGEO
  162.                NDDLGE=LRFGEO.NPQUAF(/1)
  163.                DO IDDLGE=1,NDDLGE
  164.                   IGEO.LECT(LRFGEO.NPQUAF(IDDLGE))=IDDLGE
  165.                ENDDO
  166.             ENDIF
  167. *
  168.             CALL KEEF(ITQUAF,MDISCP,MYFALS,
  169.      $           LRFPRI,IMPR,IRET)
  170.             IF (IRET.NE.0) GOTO 9999
  171.             SEGACT LRFPRI
  172.             NDDLPR=LRFPRI.NPQUAF(/1)
  173. *
  174.             CALL KEEF(ITQUAF,MDISCD,MYFALS,
  175.      $           LRFDUA,IMPR,IRET)
  176.             IF (IRET.NE.0) GOTO 9999
  177.             SEGACT LRFDUA
  178.             NDDLDU=LRFDUA.NPQUAF(/1)
  179. *
  180. * remplissage du segment DISCR
  181. *
  182. * Si le maillage donné à NLIN n'était pas QUAF au départ, il faut
  183. * vérifier que tous les ddls peuvent s'appuyer sur les points du
  184. * maillage donné
  185.             NLIGRP=NDDLPR
  186.             NLIGRD=NDDLDU
  187.             SEGINI MYDSCR
  188.             DO ILIGRP=1,NLIGRP
  189.                ICMPP=LRFPRI.NUMCMP(ILIGRP)
  190.                MYDSCR.LISINC(ILIGRP)=NCVARP.MOTS(ICMPP)
  191.                IPQUAF=LRFPRI.NPQUAF(ILIGRP)
  192.                IF (LQUAF) THEN
  193.                   MYDSCR.NOELEP(ILIGRP)=IPQUAF
  194.                ELSE
  195.                   IPGEO=IGEO.LECT(IPQUAF)
  196.                   IF (IPGEO.EQ.0) THEN
  197.                      WRITE(IOIMP,*) 'A discretization space ',MDISCP,
  198.      $                    ' is incompatible with the given mesh'
  199.                      WRITE(IOIMP,*) 'Check its element type please'
  200.                      GOTO 9999
  201.                   ELSE
  202.                      MYDSCR.NOELEP(ILIGRP)=IPGEO
  203.                   ENDIF
  204.                ENDIF
  205.             ENDDO
  206.             DO ILIGRD=1,NLIGRD
  207.                ICMPD=LRFDUA.NUMCMP(ILIGRD)
  208.                MYDSCR.LISDUA(ILIGRD)=NCVARD.MOTS(ICMPD)
  209.                IPQUAF=LRFDUA.NPQUAF(ILIGRD)
  210.                IF (LQUAF) THEN
  211.                   MYDSCR.NOELED(ILIGRD)=IPQUAF
  212.                ELSE
  213.                   IPGEO=IGEO.LECT(IPQUAF)
  214.                   IF (IPGEO.EQ.0) THEN
  215.                      WRITE(IOIMP,*) 'A discretization space ',MDISCD,
  216.      $                    ' is incompatible with the given mesh'
  217.                      WRITE(IOIMP,*) 'Check its element type please'
  218.                      GOTO 9999
  219.                   ELSE
  220.                      MYDSCR.NOELED(ILIGRD)=IPGEO
  221.                   ENDIF
  222.                ENDIF
  223.             ENDDO
  224.             SEGDES MYDSCR
  225.             SEGDES LRFDUA
  226.             SEGDES LRFPRI
  227.             IF (.NOT.LQUAF) THEN
  228.                SEGSUP IGEO
  229.                SEGDES LRFGEO
  230.             ENDIF
  231. *
  232. * remplissage des matrices élémentaires
  233. *
  234.             SEGACT JMTLS9
  235.             NBLIG=JMTLS9.WELCHE(/1)
  236.             NBCOL=JMTLS9.WELCHE(/2)
  237.             N2LIG=JMTLS9.WELCHE(/3)
  238.             N2COL=JMTLS9.WELCHE(/4)
  239.             NBPOI=JMTLS9.WELCHE(/5)
  240.             NBELM=JMTLS9.WELCHE(/6)
  241.             IF (NBLIG.NE.NDDLDU.OR.NBCOL.NE.NDDLPR.OR.N2LIG.NE.1
  242.      $           .OR.N2COL.NE.1.OR.NBPOI.NE.1) THEN
  243.                WRITE(IOIMP,*) 'Erreur dims JMTLS9'
  244.                GOTO 9999
  245.             ENDIF
  246.             NELRIG=NBELM
  247.             nligrp=nddlpr
  248.             nligrd=nddldu
  249.             SEGINI MYxMAT
  250.  
  251.             DO IELRIG=1,NELRIG
  252. *               NLIGRP=NDDLPR
  253. *               NLIGRD=NDDLDU
  254. *               SEGINI MYXMAT
  255.                DO ILIGRP=1,NLIGRP
  256.                   DO ILIGRD=1,NLIGRD
  257.                      MYXMAT.RE(ILIGRD,ILIGRP,ielrig)=
  258.      $                    JMTLS9.WELCHE(ILIGRD,ILIGRP,1,1,1,IELRIG)
  259.                   ENDDO
  260.                ENDDO
  261. *               SEGDES MYXMAT
  262. *               MYIMAT.IMATTT(IELRIG)=MYXMAT
  263.             ENDDO
  264.             if (lsym) then
  265.                call versy2(MYXMAT.RE,nligrd,nligrp,nelrig,0,kerre)
  266.                lsym=lsym.and.kerre.eq.0
  267.             endif
  268. *            write(ioimp,*) 'lsym3=',lsym
  269.  
  270.             SEGDES JMTLS9
  271. *
  272. * remplissage du chapeau
  273. *
  274.             NRIGEL=MATLS9.IRIGEL(/2)+1
  275.             SEGADJ,MATLS9
  276.             MATLS9.COERIG(NRIGEL)=1.D0
  277.             MATLS9.IRIGEL(1,NRIGEL)=MELEME
  278.             MATLS9.IRIGEL(2,NRIGEL)=0
  279.             MATLS9.IRIGEL(3,NRIGEL)=MYDSCR
  280.             MATLS9.IRIGEL(4,NRIGEL)=MYxMAT
  281.             MATLS9.IRIGEL(5,NRIGEL)=0
  282.             MATLS9.IRIGEL(6,NRIGEL)=0
  283. *
  284. * la matrice ne possède pas de symétries (a priori...)
  285. *
  286.  
  287.             MATLS9.IRIGEL(8,NRIGEL)=0
  288.             if (.not.lsym) then
  289.                MATLS9.IRIGEL(7,NRIGEL)=2
  290.                myxmat.symre = 2
  291.             else
  292.                if (impr.gt.1) then
  293.                   call erreur(-274)
  294.                endif
  295.                MATLS9.IRIGEL(7,NRIGEL)=0
  296.                myxmat.symre = 0
  297.                myxmat.symver = 1
  298.             endif
  299.             SEGDES MYxMAT
  300.          ENDIF
  301.       ENDDO
  302.       SEGDES IMTLS9
  303.       SEGDES NCVARD
  304.       SEGDES NCVARP
  305.       SEGDES MATLS9
  306.       IF (IMPR.GT.3) THEN
  307.          WRITE(IOIMP,*) 'On a créé MATLS9=',MATLS9
  308.          CALL ECROBJ('RIGIDITE',MATLS9)
  309.          CALL PRLIST
  310.       ENDIF
  311. *
  312. * Normal termination
  313. *
  314.       IRET=0
  315.       RETURN
  316. *
  317. * Format handling
  318. *
  319. *
  320. * Error handling
  321. *
  322.  9999 CONTINUE
  323.       IRET=1
  324.       WRITE(IOIMP,*) 'An error was detected in subroutine cv2ma9'
  325.       RETURN
  326. *
  327. * End of subroutine CV2MA9
  328. *
  329.       END
  330.  
  331.  
  332.  

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