Télécharger la plaquette Cast3M


fr en

Télécharger smdchp.eso

Retour à la liste

Numérotation des lignes : 

smdchp

  1. C SMDCHP    SOURCE    OF166741  24/03/28    21:15:10     11811          
  2.  
  3. C***********************************************************************
  4. C NOM         : smdchp.eso
  5. C DESCRIPTION : Sortie des CHPOINT 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 :  01/08/2022 : OF : Ameliorations diverses
  10. C HISTORIQUE :  12/01/2024 : OF : Ameliorations diverses
  11. C HISTORIQUE :  24/01/2024 : OF : Menues modifications
  12. C HISTORIQUE :  31/01/2024 : OF : Menues modifications (2)
  13. C HISTORIQUE :  08/02/2024 : OF : Correction du profil avec numerotation
  14. C HISTORIQUE :  12/02/2024 : OF : Passage a bibliotheque MED-64 bits
  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             IJGROU  : SEGMENT contenant la liste des GROUPES
  25. C             LISCHP  : SEGMENT contenant la liste des MPOVAL
  26. C             ICPR8   : SEGMENT de correspondance numero MED / Cast3M
  27. C SORTIES :   aucune
  28. C***********************************************************************
  29.  
  30.       SUBROUTINE smdchp (mfid, name, IJGROU, LISCHP, ICPR8)
  31.  
  32.       IMPLICIT INTEGER(I-N)
  33.       IMPLICIT REAL*8 (A-H,O-Z)
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC CCGEOME
  38. -INC CCMED
  39.  
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMCHPOI
  43. -INC SMLENTI
  44. -INC SMMED
  45.       SEGMENT ICPR8(nnic)
  46.  
  47.       CHARACTER*(*) name
  48.  
  49.       CHARACTER*(4) cha4F
  50.  
  51. C-----Definition des reels
  52.       REAL*8    dt
  53.  
  54. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  55.       CHARACTER*(MED_NAME_SIZE) fname
  56.       CHARACTER*(MED_NAME_SIZE) lname
  57.       CHARACTER*(MED_NAME_SIZE) mname
  58.       CHARACTER*(MED_LNAME_SIZE) pname
  59.  
  60. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  61.       CHARACTER*(MED_SNAME_SIZE) dtunit
  62.  
  63. C-----SEGMENT pour stocker les profils des familles (numero d'element local)
  64.       SEGMENT IPROFI(nbelp)
  65.       SEGMENT IPROF1(nbelp)
  66.  
  67. C-----Information sur les GROUPES
  68.       SEGMENT IJGROU
  69.         INTEGER                    ILENTI(nbgrou)
  70.         INTEGER                    IPMAIL(nbgrou)
  71.         CHARACTER*(MED_LNAME_SIZE) CNOMGR(nbgrou)
  72. C       nbgrou : Nombre de groupes
  73. C       ILENTI : pointeur LISTENTI des numeros de famille composant les groupes
  74. C       IPMAIL : pointeur MELEME du groupe en question
  75. C       CNOMGR : Noms des groupes
  76.       ENDSEGMENT
  77.  
  78. C-----SCHMED : Proprietes des CHAMPS a sortir
  79.       SEGMENT SCHMED
  80.         CHARACTER*(MED_NAME_SIZE) CCHMED(nchmed)
  81.         CHARACTER*(MED_NAME_SIZE) CPRMED(nchmed)
  82. C       CCHMED : Nom du champ  MED a creer
  83. C       CPRMED : Nom du profil MED a creer
  84.       ENDSEGMENT
  85.  
  86.       SEGMENT SLISCO
  87.         CHARACTER*(MED_SNAME_SIZE) LISSCP(nbcomp)
  88.         CHARACTER*(MED_SNAME_SIZE) LCUNIT(nbcomp)
  89.       ENDSEGMENT
  90.  
  91. C Une petite chaine pour les formats
  92.       cha4F = '(I )'
  93.  
  94.       mcret = 0
  95.  
  96. C **********************************************************************
  97. C     Traitement des CHPOINT : Champ, Profil et Valeurs
  98. C **********************************************************************
  99.       nbgrou  = IJGROU.IPMAIL(/1)
  100.       nchmed  = LISCHP.NBENTI
  101.  
  102. C Initialisations des segments de travail : SCHMED, SLISCO et IPROFI
  103. C Dimensionnement au maximum pour SLISCO(nbcomp)
  104.       nbelp  = 0
  105.       nbcomp = 0
  106.       DO ia = 1, nchmed
  107.         IPT1   = LISCHP.LIMAIL(ia)
  108.         MSOUPO = LISCHP.LICHAP(ia)
  109.         nbelp  = MAX(nbelp, IPT1.NUM(/2))
  110.         nbcomp = MAX(nbcomp, MSOUPO.NOHARM(/1))
  111.         if (ipt1.num(/1).ne.1) then
  112.           write(ioimp,*) 'SMDCHP - support chpoint incoherent',ia,ipt1
  113.         endif
  114.       END DO
  115.  
  116.       SEGINI,SCHMED,SLISCO,IPROFI
  117.  
  118.       DO ie = 1, nbcomp
  119.         SLISCO.LISSCP(ie) = ' '
  120.         SLISCO.LCUNIT(ie) = 'NO_UNIT'
  121.       END DO
  122.  
  123.       nbch = 0
  124.       nbpr = 0
  125.       DO ia = 1, nchmed
  126.         IPT1   = LISCHP.LIMAIL(ia)
  127.         fname  = LISCHP.NOCHAP(ia)
  128.         MSOUPO = LISCHP.LICHAP(ia)
  129.         nsize  = IPT1.NUM(/2)
  130.         nbcomp = MSOUPO.NOHARM(/1)
  131.  
  132.         CALL PLACE(SCHMED.CCHMED, nbch, iplace, fname)
  133.         IF (iplace .EQ. 0) THEN
  134. C-------  Creation du Champ
  135.           nbch = nbch + 1
  136.           SCHMED.CCHMED(nbch)=fname
  137.           DO ie = 1,nbcomp
  138.             SLISCO.LISSCP(ie) = MSOUPO.NOCOMP(ie)
  139.           ENDDO
  140.  
  141.           mftype = MED_FLOAT64
  142.           n4     = nbcomp
  143.           dtunit = 'NO_UNIT'
  144.           mname  = name
  145.  
  146.           CALL mfdcre(mfid, fname, mftype, n4,
  147.      &        SLISCO.LISSCP,SLISCO.LCUNIT, dtunit, mname, mcret)
  148.           IF (mcret .NE. 0) THEN
  149.             moterr    = 'smdchp / mfdcre'
  150.             interr(1) = mcret
  151.             CALL ERREUR(873)
  152.             GOTO 9999
  153.           ENDIF
  154.         ENDIF
  155.  
  156. C       Verification de controle au CAS OU on aurait oublie un MAILLAGE
  157.         CALL PLACE2(IJGROU.IPMAIL,nbgrou,IDANS,IPT1)
  158.         IF (IDANS .EQ. 0) THEN
  159. C         Determination du FORMAT automatique
  160.           IFORMA = INT(LOG10(REAL(IPT1))) + 1
  161.           IF (IFORMA.LT.1 .OR. IFORMA.GT.9) THEN
  162.             CALL ERREUR(1094)
  163.             GOTO 9999
  164.           ENDIF
  165.           WRITE(cha4F(3:3),'(I1)') IFORMA
  166.           WRITE(pname     , cha4F) IPT1
  167.         ELSE
  168.           pname  = IJGROU.CNOMGR(IDANS)
  169.         ENDIF
  170.  
  171.         CALL PLACE(SCHMED.CPRMED, nbpr, iplace, pname)
  172.         IF (iplace .EQ. 0) THEN
  173. C-------  Creation du Profil
  174.           nbpr = nbpr + 1
  175.           SCHMED.CPRMED(nbpr)=pname
  176. C- Prise en compte de la numerotation locale pour le profil
  177.           DO i = 1, nsize
  178.             IPROFI(i) = ICPR8(IPT1.NUM(1,i))
  179.           ENDDO
  180.           CALL mpfprw(mfid, pname, nsize, IPROFI(1), mcret)
  181.           IF (mcret .NE. 0) THEN
  182.             moterr    = 'smdchp / mpfprw'
  183.             interr(1) = mcret
  184.             CALL ERREUR(873)
  185.             GOTO 9999
  186.           ENDIF
  187.         ENDIF
  188.  
  189. C------ Ecriture des Valeurs du Champ
  190.         MPOVAL = MSOUPO.IPOVAL
  191.         numit  = MED_NO_IT
  192.         numdt  = LISCHP.PNUMDT(ia)
  193.         dt     = LISCHP.XTEMPS(ia)
  194.         metype = MED_NODE
  195.         mgtype = MED_NONE
  196.         mtsf   = MED_COMPACT_STMODE
  197.         lname  = ' '
  198.         mswm   = MED_NO_INTERLACE
  199.         mcs    = MED_ALL_CONSTITUENT
  200.         n4     = nsize
  201.  
  202.         CALL mfdrpw(mfid, fname, numdt, numit, dt, metype,mgtype, mtsf,
  203.      &              pname, lname, mswm, mcs, n4, MPOVAL.VPOCHA, mcret)
  204.         IF (mcret .NE. 0) THEN
  205.           moterr    = 'smdchp / mfdrpw'
  206.           interr(1) = mcret
  207.           CALL ERREUR(873)
  208.           GOTO 9999
  209.         ENDIF
  210.       ENDDO
  211.  
  212.  9999 CONTINUE
  213.       SEGSUP,SCHMED,SLISCO,IPROFI
  214.  
  215. C      RETURN
  216.       END
  217.  
  218.  
  219.  

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