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

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