Télécharger la plaquette Cast3M


fr en

Télécharger smdchm.eso

Retour à la liste

Numérotation des lignes : 

smdchm

  1. C SMDCHM    SOURCE    OF166741  24/03/28    21:15:10     11811          
  2.  
  3. C***********************************************************************
  4. C NOM         : smdchm.eso
  5. C DESCRIPTION : Sortie des MCHELM dans un fichier au format MED
  6. C***********************************************************************
  7. C HISTORIQUE :  16/10/2017 : RPAREDES : CREATION
  8. C HISTORIQUE :  07/03/2019 : CB215821 : Compatibilite avec Salome > 9.2
  9. C HISTORIQUE :  20/10/2022 : OF       : Modifications diverses
  10. C HISTORIQUE :  10/01/2024 : OF       : Modifications diverses (2)
  11. C HISTORIQUE :  22/01/2024 : OF       : Modifications diverses (3)
  12. C HISTORIQUE :  31/01/2024 : OF       : Modifications diverses (4)
  13. C HISTORIQUE :  08/02/2024 : OF       : Correction numerotation profil
  14. C HISTORIQUE :  12/02/2024 : OF       : Passage a MED 64B
  15. C***********************************************************************
  16. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  17. C en cas de modification de ce sous-programme afin de faciliter
  18. C la maintenance !
  19. C***********************************************************************
  20. C APPELE PAR : operateur (SORT 'MED') sormed.eso
  21. C***********************************************************************
  22. C ENTREES :   mfid    : Id du fichier
  23. C             name    : Nom du MAILLAGE MED courant
  24. C             IJFAM   : SEGMENT contenant la liste des FAMILLES
  25. C             IJGROU  : SEGMENT contenant la liste des GROUPES
  26. C             LISCHA  : SEGMENT contenant la liste des MCHAML
  27. C             ICPR8   : Segment numerotation noeud MED / Cast3M
  28. C SORTIES : aucune
  29. C***********************************************************************
  30.  
  31.       SUBROUTINE smdchm (mfid, name, IJFAM, IJGROU, LISCHA, ICPR8)
  32.  
  33.       IMPLICIT INTEGER(I-N)
  34.       IMPLICIT REAL*8 (A-H,O-Z)
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC CCMED
  39. -INC CCGEOME
  40.  
  41. -INC SMELEME
  42. -INC SMCHAML
  43. -INC SMINTE
  44. -INC SMLENTI
  45. -INC SMMED
  46.       SEGMENT ICPR8(nnic)
  47.  
  48.       EXTERNAL LONG
  49.  
  50. C-----Definition des reels
  51.       REAL*8    dt
  52.  
  53. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  54.       CHARACTER*(MED_NAME_SIZE) fname
  55.       CHARACTER*(MED_NAME_SIZE) lname
  56.       CHARACTER*(MED_NAME_SIZE) name
  57.       CHARACTER*(MED_NAME_SIZE) mname
  58.       CHARACTER*(MED_NAME_SIZE) pname
  59.  
  60. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  61.       CHARACTER*(MED_SNAME_SIZE) dtunit
  62.  
  63.       CHARACTER*16 TYPCH
  64.  
  65. C-----Information sur les FAMILLES
  66.       SEGMENT IJFAM
  67.         INTEGER NFAM
  68.         INTEGER                   IFAM(jf)
  69.         INTEGER                   INUMF(jf)
  70.         INTEGER                   INOGRO(jf)
  71.         CHARACTER*(MED_NAME_SIZE) CNOMFA(jf)
  72.         INTEGER                   IPROF(jf)
  73. C       jf     : Entier de dimensionnement
  74. C       NFAM   : Nombre de familles
  75. C       IFAM   : Objet MELEME (simple normalement)
  76. C       INOGRO : pointeur sur un SEGMENT NOMGRO(Noms des groupes composes de cette famille)
  77. C       CNOMFA : Nom de la famille
  78. C       IPROF  : pointeur sur un SEGMENT IPROFI pour definir le PROFIL
  79.       ENDSEGMENT
  80.  
  81. C-----SEGMENT pour stocker les profils des familles (numeros d'elements local)
  82.       SEGMENT IPROFI(nbelp)
  83.       SEGMENT IPROF1(nbelp)
  84.  
  85. C-----Information sur les GROUPES
  86.       SEGMENT IJGROU
  87.         INTEGER                    ILENTI(nbgrou)
  88.         INTEGER                    IPMAIL(nbgrou)
  89.         CHARACTER*(MED_LNAME_SIZE) CNOMGR(nbgrou)
  90. C       nbgrou : Nombre de groupes
  91. C       ILENTI : pointeur LISTENTI des numeros de famille composant les groupes
  92. C       IPMAIL : pointeur MELEME du groupe en question
  93. C       CNOMGR : Noms des groupes
  94.       ENDSEGMENT
  95.  
  96. C-----SCHMED : Proprietes des CHAMPS a sortir
  97.       SEGMENT SCHMED
  98.         CHARACTER*(MED_NAME_SIZE) CCHMED(nchmed)
  99.         CHARACTER*(MED_NAME_SIZE) CPRMED(nchmed)
  100. C       CCHMED : Nom du champ  MED a creer
  101. C       CPRMED : Nom du profil MED a creer
  102.       ENDSEGMENT
  103.  
  104.       SEGMENT SLISCO
  105.         CHARACTER*(MED_SNAME_SIZE) LISSCP(nbcomp)
  106.         CHARACTER*(MED_SNAME_SIZE) LCUNIT(nbcomp)
  107.       ENDSEGMENT
  108.  
  109.       SEGMENT LCCHAM
  110.         REAL*8  LCHAML(nbvals, nbcomp)
  111.       ENDSEGMENT
  112.  
  113. C *** Initialisation du code de retour (=0 si ok, !=0 sinon)
  114.       mcret = 0
  115.  
  116. C **********************************************************************
  117. C     Traitement des MCHAML : Champ, Profil et Valeurs
  118. C **********************************************************************
  119.       nbcomp = 0
  120.       SLISCO = 0
  121.       nbelp  = 0
  122.       IPROF1 = 0
  123.  
  124.       nbgrou  = IJGROU.IPMAIL(/1)
  125.       nchmed  = LISCHA.NBENTI
  126.       SEGINI,SCHMED
  127.  
  128.       nbch = 0
  129.       nbpr = 0
  130.       DO ia = 1, nchmed
  131.         fname  = LISCHA.NOCHAP(ia)
  132.         IPT1   = LISCHA.LIMAIL(ia)
  133.         MCHAML = LISCHA.LICHAP(ia)
  134.         nbc    = MCHAML.IELVAL(/1)
  135.  
  136. C       On ne sort que les composantes de type 'REAL*8'
  137.         ic=0
  138.         DO ie = 1,nbc
  139.           TYPCH = MCHAML.TYPCHE(ie)
  140.           IF(TYPCH(1:8) .EQ. 'REAL*8  ') ic=ic+1
  141.         ENDDO
  142.         IF (ic .EQ. 0) GOTO 100
  143.         nbcomp=ic
  144.  
  145.         CALL PLACE(SCHMED.CCHMED, nbch, iplace, fname)
  146.         IF (iplace .EQ. 0) THEN
  147. C-------- Creation du Champ
  148.           nbch = nbch + 1
  149.           SCHMED.CCHMED(nbch)=fname
  150.  
  151. C         Recyclage eventuel du POINTEUR SLISCO
  152.           IF (SLISCO .GT. 0) THEN
  153.             IF (nbcomp .GT. SLISCO.LISSCP(/2)) SEGADJ,SLISCO
  154.           ELSE
  155.             SEGINI,SLISCO
  156.           ENDIF
  157.  
  158.           ic = 0
  159.           DO ie = 1, nbc
  160.             TYPCH = MCHAML.TYPCHE(ie)
  161.             IF (TYPCH(1:8) .EQ. 'REAL*8  ') THEN
  162.               ic=ic+1
  163.               SLISCO.LISSCP(ic) = MCHAML.NOMCHE(ie)
  164.               SLISCO.LCUNIT(ic) = 'NO_UNIT'
  165.             ENDIF
  166.           ENDDO
  167.  
  168.           mftype = MED_FLOAT64
  169.           n4     = nbcomp
  170.           dtunit = 'NO_UNIT'
  171.           mname  = name
  172.  
  173.           CALL mfdcre(mfid, fname, mftype, n4,
  174.      &        SLISCO.LISSCP,SLISCO.LCUNIT, dtunit, mname, mcret)
  175.           IF (mcret .NE. 0) THEN
  176.             moterr    = 'smdchm / mfdcre'
  177.             interr(1) = mcret
  178.             CALL ERREUR(873)
  179.             RETURN
  180.           ENDIF
  181.         ENDIF
  182.  
  183. C       Verification de controle au CAS OU on aurait oublie un MAILLAGE
  184.         CALL PLACE2(IJGROU.IPMAIL,nbgrou,IDANS,IPT1)
  185.         IF (IDANS .EQ. 0) THEN
  186.           CALL ERREUR(503)
  187.           RETURN
  188.         ENDIF
  189.  
  190.         pname  = IJGROU.CNOMGR(IDANS)
  191.         NBNN   = IPT1.NUM(/1)
  192.         nbelp  = IPT1.NUM(/2)
  193.         nsize  = nbelp
  194.  
  195.         CALL PLACE(SCHMED.CPRMED, nbpr, iplace, pname)
  196.         IF (iplace .EQ. 0) THEN
  197. C-------  Creation du Profil
  198.           nbpr = nbpr + 1
  199.           SCHMED.CPRMED(nbpr)=pname
  200.  
  201.           MLENTI=IJGROU.ILENTI(IDANS)
  202.  
  203. C         Recyclage eventuel du POINTEUR IPROF1
  204.           IF (IPROF1 .GT. 0) THEN
  205.             IF (nbelp .GT. IPROF1(/1)) SEGADJ,IPROF1
  206.           ELSE
  207.             SEGINI,IPROF1
  208.           ENDIF
  209.  
  210. C         Remise dans l'ordre des familles du groupe sinon le champ est un melange...
  211.           jg=MLENTI.LECT(/1)
  212.           SEGINI,MLENT1
  213.           IJGROU.ILENTI(IDANS)=MLENT1
  214.           jg2 =0
  215.           iel1=1
  216.  8        CONTINUE
  217.           DO ii = 1, jg
  218.             ifa   = MLENTI.LECT(ii)
  219.             IPT2  = IJFAM.IFAM(ifa)
  220.             NBEL2 = IPT2.NUM(/2)
  221.             DO jj = 1, NBNN
  222.               IF (IPT2.NUM(jj,1) .NE. IPT1.NUM(jj,iel1)) GOTO 10
  223.             ENDDO
  224.             jg2=jg2+1
  225.             MLENT1.LECT(jg2)=ifa
  226.             iel1=iel1+NBEL2
  227.             IF (jg2 .EQ. jg) GOTO 9
  228.             GOTO 8
  229.  10         CONTINUE
  230.           ENDDO
  231.  9        CONTINUE
  232.           SEGSUP,MLENTI
  233.           MLENTI=MLENT1
  234.  
  235.           itot = 0
  236.           DO ii = 1, jg
  237.             ifa   =MLENTI.LECT(ii)
  238.             IPROFI=IJFAM.IPROF(ifa)
  239.             DO jj=1,IPROFI(/1)
  240.               itot         = itot+1
  241.               IPROF1(itot) = IPROFI(jj)
  242.             ENDDO
  243.           ENDDO
  244.  
  245.           CALL mpfprw(mfid, pname, nsize, IPROF1(1), mcret)
  246.           IF (mcret .NE. 0) THEN
  247.             moterr    = 'smdchm / mpfprw'
  248.             interr(1) = mcret
  249.             CALL ERREUR(873)
  250.             RETURN
  251.           ENDIF
  252.         ENDIF
  253.  
  254. C------ Preparation & Ecriture des Valeurs du Champ
  255.         ISUPP  = LISCHA.ISUPOR(ia,1)
  256.         MINTE  = LISCHA.ISUPOR(ia,2)
  257.         IF    (ISUPP .EQ. 1) THEN
  258. C         Cas MCHAML aux NOEUDS
  259.           nnno   = NBNN
  260.           metype = MED_NODE_ELEMENT
  261.           IPER   = MEDPER(IPT1.ITYPEL)
  262.         ELSE
  263. C         Cas MCHAML possedant un SEGMENT MINTE
  264.           nnno   = MINTE.POIGAU(/1)
  265.           metype = MED_CELL
  266.           IPER   = -1
  267.         ENDIF
  268.         nbvals = nnno*nbelp
  269.  
  270. C       Recyclage eventuel du POINTEUR LCCHAM
  271.         IF (LCCHAM .GT. 0) THEN
  272.           IF (nbvals.GT.LCCHAM.LCHAML(/1) .OR.
  273.      &        nbcomp.GT.LCCHAM.LCHAML(/2))    SEGADJ,LCCHAM
  274.         ELSE
  275.           SEGINI,LCCHAM
  276.         ENDIF
  277.  
  278.         ic = 0
  279.         DO ie = 1,nbcomp
  280.           TYPCH = MCHAML.TYPCHE(ie)
  281.           IF (TYPCH(1:8) .NE. 'REAL*8  ') GOTO 130
  282.           ic = ic + 1
  283.  
  284.           MELVAL = MCHAML.IELVAL(ie)
  285.           N1PTEL = MELVAL.VELCHE(/1)
  286.           N1EL   = MELVAL.VELCHE(/2)
  287.           MELVA1 = 0
  288.           IF (IPER .GE. 0 .AND. N1PTEL .GT. 1) THEN
  289. C           Permutation des noeuds pour correspondre au formalisme MED
  290.             N2PTEL = 0
  291.             N2EL   = 0
  292.             SEGINI,MELVA1
  293.             do iel = 1, N1EL
  294.               MELVA1.VELCHE(1,iel) = MELVAL.VELCHE(1,iel)
  295.               do ipt = 1,N1PTEL-1
  296.                 jpt = IPERM(IPER+ipt)
  297.                 MELVA1.VELCHE(ipt+1,iel)=MELVAL.VELCHE(jpt,iel)
  298.               enddo
  299.             enddo
  300.             MELVAL = MELVA1
  301.           ENDIF
  302.  
  303.           idc = 0
  304.           DO iel = 1, nbelp
  305.             I1EL = MIN(iel, N1EL)
  306.             DO ino = 1,nnno
  307.               idc    = idc + 1
  308.               I1PTEL = MIN(ino, N1PTEL)
  309.               LCCHAM.LCHAML(idc, ic) = MELVAL.VELCHE(I1PTEL,I1EL)
  310.             ENDDO
  311.           ENDDO
  312.           IF (MELVA1 .GT. 0) SEGSUP,MELVA1
  313.  130      CONTINUE
  314.         ENDDO
  315.  
  316.         numdt  = LISCHA.PNUMDT(ia)
  317.         numit  = MED_NO_IT
  318.         dt     = LISCHA.XTEMPS(ia)
  319.         mgtype = MEDEL(IPT1.ITYPEL)
  320.         mtsf   = MED_COMPACT_STMODE
  321.         lname  = ' '
  322.         mswm   = MED_NO_INTERLACE
  323.         mcs    = MED_ALL_CONSTITUENT
  324.         n4     = nsize
  325.  
  326.         CALL mfdrpw(mfid, fname, numdt, numit, dt, metype,mgtype, mtsf,
  327.      &        pname, lname, mswm, mcs, n4, LCCHAM.LCHAML, mcret)
  328.         IF (mcret .NE. 0) THEN
  329.           moterr    = 'smdchm / mfdrpw'
  330.           interr(1) = mcret
  331.           CALL ERREUR(873)
  332.           RETURN
  333.         ENDIF
  334.  100    CONTINUE
  335.       ENDDO
  336.  
  337.       SEGSUP,SCHMED
  338.       IF (SLISCO.GT.0) SEGSUP,SLISCO
  339.  
  340. c      return
  341.       END
  342.  
  343.  
  344.  

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