Télécharger la plaquette Cast3M


fr en

Télécharger lmdchm.eso

Retour à la liste

Numérotation des lignes : 

lmdchm

  1. C LMDCHM    SOURCE    OF166741  24/03/28    21:15:04     11811          
  2.  
  3. C***********************************************************************
  4. C NOM         : lmdchm.eso
  5. C DESCRIPTION : Sortie d'un MCHAML au format .med
  6. C***********************************************************************
  7. C HISTORIQUE :  23/10/2017 : RPAREDES : Creation
  8. C HISTORIQUE :  22/01/2024 : OF       : Menues corrections
  9. C HISTORIQUE :  31/01/2024 : OF       : Menues corrections (2)
  10. C HISTORIQUE :  12/02/2024 : OF       : Passage en MED 64b 
  11. C***********************************************************************
  12. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  13. C en cas de modification de ce sous-programme afin de faciliter
  14. C la maintenance !
  15. C***********************************************************************
  16. C APPELE PAR : operateur (LIRE 'MED') lirmed.eso
  17. C***********************************************************************
  18. C ENTREES :
  19. C             mfid    : Id du fichier
  20. C             MTABLE  : Table avec la geometrie
  21. C             SLSCHA  : Segment avec l'information des champs
  22. C             SLSFUS  : Segment avec la liste de champs a creer
  23. C             IPDT    : Pas de Tps
  24. C SORTIES : ISOR : Pointeur vers le MCHAML
  25. C***********************************************************************
  26.       SUBROUTINE LMDCHM(mfid, MTABLE, SLSCHA, SLSFUS, IPDT, ISOR)
  27.  
  28.       IMPLICIT INTEGER(i-n)
  29.       IMPLICIT REAL*8(a-h,o-z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC CCGEOME
  34. -INC CCMED
  35.  
  36. -INC SMELEME
  37. -INC SMCOORD
  38. -INC SMLMOTS
  39. -INC SMTABLE
  40. -INC SMCHAML
  41.  
  42. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  43.       CHARACTER*(MED_SNAME_SIZE) dtunit
  44.  
  45. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  46.       CHARACTER*(MED_NAME_SIZE) lname, fname, pname, mname
  47.  
  48.       CHARACTER*(MED_NAME_SIZE) nommai, cha64a
  49.  
  50.       CHARACTER*8   charre, typobj
  51.       LOGICAL       login, logre
  52.  
  53.       EXTERNAL LONG
  54.  
  55. C ***** Declaration des segments
  56. C----- SEG SLSCHA
  57. C         LISMAI : nom du maillage
  58. C         ncham  : nombre de champs (CHPOINT ou MCHAML)
  59. C         LISCHA : liste des noms de champs
  60. C         LSCHIN : liste de SEG CHAINF (information)
  61. C         LSPARA : liste de SEG CHAPAR (parametres)
  62.       SEGMENT SLSCHA
  63.         CHARACTER*(MED_NAME_SIZE) LISMAI
  64.         CHARACTER*(MED_NAME_SIZE) LISCHA(ncham)
  65.         INTEGER                   LSCHIN(ncham), LSPARA(ncham)
  66.       ENDSEGMENT
  67.  
  68.       SEGMENT SLSFUS
  69.         INTEGER      CHAFUS(nbfus)
  70.       ENDSEGMENT
  71.  
  72.       SEGMENT CHAINF
  73. C         nc     :   nombre de sequences de calcul dans le champ
  74. C         ncomp  :   nombre de composantes
  75. C         INUMDT :   liste de numeros de pas de tps
  76. C         INUMIT :   liste de numeros d'iteration
  77. C         ISCHPR :   liste de SEG CHAPRO (profil)
  78. C         XDT    :   liste de pas de tps
  79. C         CNAME  :   liste de noms des composants
  80. C         CUNIT  :   liste d'unites des composants
  81.         INTEGER      INUMDT(nc), INUMIT(nc), ISCHPR(nc)
  82.         REAL*8       XDT(nc)
  83.         CHARACTER*(MED_SNAME_SIZE) CNAME(ncomp), CUNIT(ncomp)
  84.       ENDSEGMENT
  85.  
  86. C----- SEG CHAPAR
  87. C         ncpars : nombre de parametres par champ
  88. C         CHAPAR : nom du parametre
  89. C         CPARVL : valeur du parametre
  90.       SEGMENT CHAPAR
  91.         CHARACTER*(MED_SNAME_SIZE) CPARNM(ncpars)
  92.         INTEGER                    CPARVL(ncpars)
  93.       ENDSEGMENT
  94.  
  95. C----- SEG CHAPRO
  96. C         nprof  : nombre de profils
  97. C         CTYPE  : type de champ
  98. C         CPRONA : nom du profil
  99. C         CETYPE : entity type
  100. C         CGTYPE : geometry type
  101.       SEGMENT CHAPRO
  102.         CHARACTER*8               CTYPE(nprof)
  103.         CHARACTER*(MED_NAME_SIZE) CPRONA(nprof)
  104.         INTEGER    CETYPE(nprof), CGTYPE(nprof)
  105.       ENDSEGMENT
  106.  
  107.       SEGMENT MCNAM4
  108.         CHARACTER*4 CNAME4(ncomp)
  109.       ENDSEGMENT
  110.  
  111.       SEGMENT SCHAVL
  112.         REAL*8 CHAVAL(n, n2)
  113.       ENDSEGMENT
  114.       POINTEUR SCHAV1.SCHAVL
  115.  
  116. C***********************************************************************
  117. C      Ecriture du MCHAML
  118. C***********************************************************************
  119.       charre = ' '
  120.  
  121.       mcret = 0
  122.  
  123. C-----Initialisation
  124.       lname  = ' '
  125.       MCHELM = 0
  126.       ISOR   = 0
  127.       ifoch1 = IFOUR
  128.       infch1 = 2
  129.       infch3 = 0
  130.       infch5 = 0
  131.       IPER   = 0
  132.  
  133.       mswm = MED_NO_INTERLACE
  134.       mcs  = MED_ALL_CONSTITUENT
  135.  
  136. C---- Boucle sur les champs a lire
  137.       nbfus  = SLSFUS.CHAFUS(/1)
  138.       DO ia = 1,nbfus
  139.         icha   = SLSFUS.CHAFUS(ia)
  140.         nommai = SLSCHA.LISMAI
  141.         fname  = SLSCHA.LISCHA(icha)
  142.         CHAINF = SLSCHA.LSCHIN(icha)
  143.         CHAPAR = SLSCHA.LSPARA(icha)
  144.         CHAPRO = CHAINF.ISCHPR(IPDT)
  145.         numdt  = CHAINF.INUMDT(IPDT)
  146.         numit  = CHAINF.INUMIT(IPDT)
  147.         IF (CHAPAR .LE. 0) THEN
  148.           ncpars = 0
  149.         ELSE
  150.           ncpars = CHAPAR.CPARVL(/1)
  151.         ENDIF
  152.         n2     = CHAINF.CNAME(/2)
  153.  
  154. C-------Recherche de parametres
  155.         IF (ncpars .GT. 0) THEN
  156.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'IFOCHE')
  157.           IF (ipar.GT.0) THEN
  158.             ifoch1 = CHAPAR.CPARVL(ipar)
  159.           ENDIF
  160.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'INFCHE1')
  161.           IF (ipar.GT.0) THEN
  162.             infch1 = CHAPAR.CPARVL(ipar)
  163.           ENDIF
  164.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'INFCHE3')
  165.           IF (ipar.GT.0) THEN
  166.             infch3 = CHAPAR.CPARVL(ipar)
  167.           ENDIF
  168.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'INFCHE5')
  169.           IF (ipar.GT.0) THEN
  170.             infch5 = CHAPAR.CPARVL(ipar)
  171.           ENDIF
  172.         ENDIF
  173.  
  174. C-------Definition initiale du MCHAML
  175.         n1 = CHAPRO.CETYPE(/1)
  176.         n3 = 6
  177.         l1 = 64
  178.         SEGINI MCHEL1
  179.         MCHEL1.TITCHE = 'SCALAIRE'
  180.         MCHEL1.IFOCHE = ifoch1
  181.  
  182.         DO ib=1,n1
  183. C---------Definition de IMACHE
  184.           pname  = CHAPRO.CPRONA(ib)
  185.           metype = CHAPRO.CETYPE(ib)
  186.           mgtype = CHAPRO.CGTYPE(ib)
  187.  
  188.           IF (pname .NE. ' ') THEN
  189.             cha64a = pname
  190.           ELSE
  191.             cha64a = nommai
  192.           ENDIF
  193.  
  194.           typobj = 'MAILLAGE'
  195.           CALL ACCTAB(MTABLE,'MOT' ,ival  ,xval  ,cha64a,login,iobin,
  196.      &                       typobj,ivalre,xvalre,charre,logre,iobre)
  197.           IF (IERR.NE.0) RETURN
  198.  
  199. C         Constituant 'MED' en attendant de pouvoir le relire
  200.           MCHEL1.CONCHE(ib) = 'MED'
  201.           IF (pname .NE. ' ') THEN
  202.             MCHEL1.IMACHE(ib) = iobre
  203.           ELSE
  204.             IPT1 = iobre
  205.             SEGACT IPT1
  206.             itype  = MEDEL(IPT1.ITYPEL)
  207.             nbsous = IPT1.LISOUS(/1)
  208.             IF (itype .EQ. mgtype) THEN
  209.               MCHEL1.IMACHE(ib) = IPT1
  210.               nbnode = IPT1.NUM(/1)
  211.               nbelem = IPT1.NUM(/2)
  212.             ELSE
  213.               isea1 = 0
  214.               IF (nbsous .GT. 0) THEN
  215.                 DO ic=1,nbsous
  216.                   IPT2 = IPT1.LISOUS(ic)
  217.                   SEGACT IPT2
  218.                   itype2 = MEDEL(IPT2.ITYPEL)
  219.                   IF (itype2 .EQ. mgtype) THEN
  220.                     isea1 = 1
  221.                     nbnode = IPT2.NUM(/1)
  222.                     nbelem = IPT2.NUM(/2)
  223.                     MCHEL1.IMACHE(ib) = IPT2
  224.                     GOTO 10
  225.                   ENDIF
  226.                 ENDDO
  227.  10             CONTINUE
  228.               ENDIF
  229.               IF (isea1 .EQ. 0) THEN
  230.                 CALL ERREUR(21)
  231.                 RETURN
  232.               ENDIF
  233.             ENDIF
  234.           ENDIF
  235.  
  236. C         Information sur le champ de nom "fname"
  237.           CALL mfdfin(mfid, fname, mname, lmesh, mftype,
  238.      &                CHAINF.CNAME, CHAINF.CUNIT, dtunit, n4, mcret)
  239.           IF (mcret .NE. 0) THEN
  240.             moterr    = 'lmdchm / mfdfin'
  241.             interr(1) = mcret
  242.             CALL ERREUR(873)
  243.             RETURN
  244.           ENDIF
  245.  
  246. C---------Restitution des valeurs
  247.           IF (pname .NE. ' ') THEN
  248. C-----------Taille du profil
  249.             CALL mpfpsn(mfid, pname, n4, mcret)
  250.             IF (mcret .NE. 0) THEN
  251.               moterr   = 'lmdchm / mpfpsn'
  252.               interr(1)= mcret
  253.               CALL ERREUR(873)
  254.               RETURN
  255.             ENDIF
  256.  
  257. C-----------Nombre de valeurs
  258.             IF     (metype .EQ. MED_NODE_ELEMENT) THEN
  259.               infch6 = 1
  260.             ELSEIF (metype .EQ. MED_CELL        ) THEN
  261.               infch6 = 2
  262.             ENDIF
  263.             mtsf   = MED_COMPACT_STMODE
  264.             CALL mfdnpn(mfid, fname, numdt, numit, metype, mgtype,
  265.      &                  pname, mtsf, n4, lname, it1, nval, mcret)
  266.             IF (mcret .NE. 0) THEN
  267.               moterr    = 'lmdchm / mfdnpn'
  268.               interr(1) = mcret
  269.               CALL ERREUR(873)
  270.               RETURN
  271.             ENDIF
  272.  
  273.             n1el   = nval
  274.             n1ptel = it1
  275.             n2el   = 0
  276.             n2ptel = 0
  277.  
  278.             n = n1ptel * n1el
  279.             SEGINI SCHAVL,SCHAV1
  280.             CALL mfdrpr(mfid, fname, numdt, numit, metype, mgtype,
  281.      &                  mtsf, pname, mswm, mcs, SCHAV1.CHAVAL, mcret)
  282.             IF (mcret .NE. 0) THEN
  283.               moterr    = 'lmdchm / mfdrpr'
  284.               interr(1) = mcret
  285.               CALL ERREUR(873)
  286.               RETURN
  287.             ENDIF
  288.  
  289.           ELSE
  290. C-----------Nombre de valeurs
  291.             IF      (metype .EQ. MED_NODE_ELEMENT) THEN
  292.               infch6 = 1
  293.               n1ptel = nbnode
  294.             ELSE IF (metype .EQ. MED_CELL        ) THEN
  295.               infch6 = 2
  296.               n1ptel = 1
  297.             ENDIF
  298.  
  299.             CALL mfdnva(mfid,fname,numdt,numit,metype,mgtype,nval,mcret)
  300.             IF (mcret .NE. 0) THEN
  301.               moterr    = 'lmdchm / mfdnva'
  302.               interr(1) = mcret
  303.               CALL ERREUR(873)
  304.               RETURN
  305.             ENDIF
  306.  
  307.             n1el   = nbelem
  308.             n2el   = 0
  309.             n2ptel = 0
  310.  
  311.             n = n1ptel * n1el
  312.             SEGINI SCHAVL,SCHAV1
  313.             CALL mfdrvr(mfid, fname, numdt, numit, metype, mgtype,
  314.      &                  mswm, mcs, SCHAV1.CHAVAL, mcret)
  315.             IF (mcret .NE. 0) THEN
  316.               moterr    = 'lmdchm / mfdrvr'
  317.               interr(1) = mcret
  318.               CALL ERREUR(873)
  319.               RETURN
  320.             ENDIF
  321.           ENDIF
  322.  
  323. C         Conversion des types MED en REAL*8 suivant les cas
  324.           ITAIL=n*n2
  325. C         On envoie le meme tableau plusieurs fois pour le recuperer
  326. C         dans MTCONV selon plusieurs types (INTEGER*4, etc.)
  327.           itypd = mftype
  328.           ITAIL = n*n2
  329.           iret  = 0
  330.           CALL MTCONV(itypd,SCHAV1.CHAVAL,SCHAV1.CHAVAL,
  331.      &                      SCHAV1.CHAVAL,SCHAV1.CHAVAL, ITAIL,
  332.      &                      SCHAVL.CHAVAL,iret)
  333.           mcret = iret
  334.           IF (mcret .NE. 0) RETURN
  335.  
  336. C---------Definition de INFCHE
  337.           MCHEL1.INFCHE(ib, 1) = infch1
  338.           MCHEL1.INFCHE(ib, 3) = infch3
  339.           MCHEL1.INFCHE(ib, 5) = infch5
  340.           MCHEL1.INFCHE(ib, 6) = infch6
  341.  
  342. C---------Definition de MCHAML
  343.           SEGINI,MCHAML
  344.           DO ic = 1, n2
  345.             MCHAML.NOMCHE(ic) = CHAINF.CNAME(ic)(1:8)
  346.             IF (MCHAML.NOMCHE(ic) .EQ. '        ') THEN
  347.               MCHAML.NOMCHE(ic) = 'SCAL    '
  348.             ENDIF
  349.             MCHAML.TYPCHE(ic) = 'REAL*8'
  350.  
  351.             IF (infch6 .EQ. 1) THEN
  352. C             Cas MCHAML aux NOEUDS
  353.               IPT1 = MCHEL1.IMACHE(ib)
  354.               SEGACT,IPT1
  355.               IPER = MEDPER(IPT1.ITYPEL)
  356.             ELSE
  357. C             Cas MCHAML au GRAVITE
  358.               IPER = -1
  359.             ENDIF
  360.  
  361.             SEGINI,MELVAL
  362.             icc = 1
  363.             IF (IPER .LT. 0) THEN
  364.               DO il=1,n1el
  365.                 DO im=1,n1ptel
  366.                   MELVAL.VELCHE(im,il) = SCHAVL.CHAVAL(icc, ic)
  367.                   icc = icc + 1
  368.                 ENDDO
  369.               ENDDO
  370.             ELSE
  371.               DO il=1,n1el
  372.                 MELVAL.VELCHE(1,il) = SCHAVL.CHAVAL(icc, ic)
  373.                 icc = icc + 1
  374.                 DO im = 1,n1ptel-1
  375.                   jm = IPERM(IPER+im)
  376.                   MELVAL.VELCHE(jm,il) = SCHAVL.CHAVAL(icc, ic)
  377.                   icc = icc + 1
  378.                 ENDDO
  379.               ENDDO
  380.             ENDIF
  381.  
  382.             SEGACT MELVAL*NOMOD
  383.             MCHAML.IELVAL(ic) = MELVAL
  384.           ENDDO
  385.  
  386.           SEGSUP SCHAVL
  387.           SEGACT MCHAML*NOMOD
  388.           MCHEL1.ICHAML(ib) = MCHAML
  389.         ENDDO
  390.         SEGACT MCHEL1*NOMOD
  391.  
  392. C-------Fusion des champs
  393.         IF (MCHELM .EQ. 0) THEN
  394.           MCHELM = MCHEL1
  395.         ELSE
  396.           CALL FUSCHL(MCHELM, MCHEL1, IRECHE)
  397.           IF (IERR .NE. 0) RETURN
  398.           MCHELM = IRECHE
  399.         ENDIF
  400.       ENDDO
  401.  
  402.       ISOR = MCHELM
  403.  
  404. c      return
  405.       END
  406.  
  407.  
  408.  

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