Télécharger la plaquette Cast3M


fr en

Télécharger lmdchp.eso

Retour à la liste

Numérotation des lignes : 

lmdchp

  1. C LMDCHP    SOURCE    OF166741  24/03/28    21:15:04     11811          
  2.  
  3. C***********************************************************************
  4. C NOM         : lmdchp.eso
  5. C DESCRIPTION : Lecture d'un CHPOINT au format .med
  6. C***********************************************************************
  7. C HISTORIQUE : 23/10/2017 : RPAREDES : Creation
  8. C HISTORIQUE : 20/10/2022 : OF : modifications diverses
  9. C HISTORIQUE : 11/01/2024 : OF : modifications diverses
  10. C HISTORIQUE : 24/01/2024 : OF : menues modifications
  11. C HISTORIQUE : 31/01/2024 : OF : menues modifications (2)
  12. C HISTORIQUE : 12/02/2024 : OF : Passage en MED 64B
  13. C***********************************************************************
  14. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  15. C en cas de modification de ce sous-programme afin de faciliter
  16. C la maintenance !
  17. C***********************************************************************
  18. C APPELE PAR : operateur (LIRE 'MED') lirmed.eso
  19. C***********************************************************************
  20. C ENTREES :   MFID    : Id du fichier
  21. C             MTABLE  : Table avec la geometrie
  22. C             NBNOIN  : Numerotation de noeuds courant
  23. C             SLSCHA  : Segment avec l'information des champs
  24. C             SLSFUS  : Segment avec la liste de champs a creer
  25. C             IPDT    : Pas de Tps
  26. C SORTIES :   ISOR    : Pointeur vers le CHPOINT
  27. C***********************************************************************
  28.  
  29.       SUBROUTINE LMDCHP(MFID, MTABLE, NBNOIN, SLSCHA,SLSFUS, IPDT, ISOR)
  30.  
  31.       IMPLICIT INTEGER(i-n)
  32.       IMPLICIT REAL*8(a-h,o-z)
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCMED
  37. -INC CCGEOME
  38.  
  39. -INC SMELEME
  40. -INC SMCOORD
  41. -INC SMLMOTS
  42. -INC SMTABLE
  43. -INC SMCHPOI
  44. -INC TMTRAV
  45.  
  46. C Chaines de Caractere de longueur MED_NAME_SIZE=64
  47.       CHARACTER*(MED_NAME_SIZE) lname
  48.       CHARACTER*(MED_NAME_SIZE) fname
  49.       CHARACTER*(MED_NAME_SIZE) pname
  50.       CHARACTER*(MED_NAME_SIZE) mname
  51.  
  52.       CHARACTER*4   cha4F
  53.       CHARACTER*8   charre, typobj
  54.       CHARACTER*(LOCHPO)  cha8a
  55.       CHARACTER*(MED_NAME_SIZE+5) nommai
  56.       CHARACTER*16  cha16b
  57.       LOGICAL       login, logre
  58.  
  59.       EXTERNAL LONG
  60.  
  61. C ***** Declaration des segments
  62. C----- SEG SLSCHA
  63. C         LISMAI : nom du maillage
  64. C         ncham  : nombre de champs (CHPOINT ou MCHAML)
  65. C         LISCHA : liste des noms de champs
  66. C         LSCHIN : liste de SEG CHAINF (information)
  67. C         LSPARA : liste de SEG CHAPAR (parametres)
  68.       SEGMENT SLSCHA
  69.         CHARACTER*(MED_NAME_SIZE) LISMAI
  70.         CHARACTER*(MED_NAME_SIZE) LISCHA(ncham)
  71.         INTEGER                   LSCHIN(ncham), LSPARA(ncham)
  72.       ENDSEGMENT
  73.  
  74.       SEGMENT SLSFUS
  75.         INTEGER      CHAFUS(nbfus)
  76.       ENDSEGMENT
  77.  
  78.       SEGMENT CHAINF
  79. C         nseq   :   nombre de sequences de calcul dans le champ
  80. C         ncomp  :   nombre de composantes
  81. C         INUMDT :   liste de numeros de pas de tps
  82. C         INUMIT :   liste de numeros d'iteration
  83. C         ISCHPR :   liste de SEG CHAPRO (profil)
  84. C         XDT    :   liste de pas de tps
  85. C         CNAME  :   liste de noms des composants
  86. C         CUNIT  :   liste d'unites des composants
  87.         INTEGER      INUMDT(nseq), INUMIT(nseq), ISCHPR(nseq)
  88.         REAL*8       XDT(nseq)
  89.         CHARACTER*(MED_SNAME_SIZE) CNAME(ncomp), CUNIT(ncomp)
  90.       ENDSEGMENT
  91.  
  92. C----- SEG CHAPAR
  93. C         ncpars : nombre de parametres par champ
  94. C         CHAPAR : nom du parametre
  95. C         CPARVL : valeur du parametre
  96.       SEGMENT CHAPAR
  97.         CHARACTER*(MED_SNAME_SIZE) CPARNM(ncpars)
  98.         INTEGER                    CPARVL(ncpars)
  99.       ENDSEGMENT
  100.  
  101. C----- SEG CHAPRO
  102. C         nprof  : nombre de profils
  103. C         CTYPE  : type de champ
  104. C         CPRONA : nom du profil
  105. C         CETYPE : entity type
  106. C         CGTYPE : geometry type
  107.       SEGMENT CHAPRO
  108.         CHARACTER*8               CTYPE(nprof)
  109.         CHARACTER*(MED_NAME_SIZE) CPRONA(nprof)
  110.         INTEGER    CETYPE(nprof), CGTYPE(nprof)
  111.       ENDSEGMENT
  112.  
  113.       SEGMENT MCNAM8
  114.         CHARACTER*(LOCHPO) CNAME8(ncomp)
  115.       ENDSEGMENT
  116.  
  117.       SEGMENT SCHAVL
  118.         REAL*8 CHAVAL(nbnode, nnin)
  119.       ENDSEGMENT
  120.  
  121.       SEGMENT SPROFI
  122.         INTEGER LPROFI(nsize)
  123.       ENDSEGMENT
  124.  
  125.       SEGMENT STPROF
  126.         INTEGER LTPROF(nbfus, ntprof)
  127.       ENDSEGMENT
  128.  
  129.       SEGMENT SINT4
  130.         INTEGER INT4(nsize)
  131.       ENDSEGMENT
  132.  
  133. C***********************************************************************
  134. C      Ecriture du CHPOINT
  135. C***********************************************************************
  136.       mcret = 0
  137.  
  138. C-----Initialisation
  139.       mswm   = MED_NO_INTERLACE
  140.       mtsf   = MED_COMPACT_STMODE
  141.       metype = MED_NODE
  142.       mgtype = MED_NONE
  143.       mcs    = MED_ALL_CONSTITUENT
  144.       lname  = ' '
  145.       ijatt  = 1
  146.       ifopo  = IFOUR
  147.  
  148.       nbfus  = SLSFUS.CHAFUS(/1)
  149.  
  150. C-----Information preliminaire
  151.       ntprof = 0
  152.       DO ia = 1, nbfus
  153.         icha   = SLSFUS.CHAFUS(ia)
  154.         CHAINF = SLSCHA.LSCHIN(icha)
  155.         CHAPRO = CHAINF.ISCHPR(IPDT)
  156.         nprof  = CHAPRO.CETYPE(/1)
  157.         ntprof = MAX(ntprof, nprof)
  158.       if (iimpi.eq.1972) then
  159.         write(ioimp,*) 'LMDCHP - Prof :',ia,nprof,ntprof
  160.       endif
  161.       ENDDO
  162.       SEGINI,STPROF
  163.  
  164.       nnin  = 0
  165.       nnnoe = 0
  166.       SEGINI,MTRAV
  167.  
  168.       innin = 0
  169.       innoe = 0
  170.  
  171.       cha4F = '(I )'
  172.  
  173.       if (iimpi.eq.1972) then
  174.         write(ioimp,*) 'LMDCHP - 1 -',nbfus
  175.       endif
  176.       ia = LONG(SLSCHA.LISMAI)
  177.       nommai = SLSCHA.LISMAI(1:ia)//'_POI1'
  178.  
  179. C-DEB-1----Definition initiale de MTRAV
  180.       DO ia = 1, nbfus
  181.         icha   = SLSFUS.CHAFUS(ia)
  182.         CHAINF = SLSCHA.LSCHIN(icha)
  183.         fname  = SLSCHA.LISCHA(icha)
  184.         CHAPAR = SLSCHA.LSPARA(icha)
  185.         CHAPRO = CHAINF.ISCHPR(IPDT)
  186.         IF (CHAPAR .LE. 0) THEN
  187.           ncpars = 0
  188.         ELSE
  189.           ncpars = CHAPAR.CPARVL(/1)
  190.         ENDIF
  191.       if (iimpi.eq.1972) then
  192.         write(ioimp,*) 'LMDCHP - 1 -',ia,nommai,ncpars,fname
  193.       endif
  194.  
  195. C-----Recherche de parametres ; ATTRIBUT et IFOPOI du CHPOINT
  196.         IF ((ia .EQ. 1) .AND. (ncpars .GT. 0)) THEN
  197.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'JATTRI')
  198.           IF (ipar.GT.0) THEN
  199.             ijatt = CHAPAR.CPARVL(ipar)
  200.           ENDIF
  201.           CALL PLACE(CHAPAR.CPARNM, ncpars, ipar, 'IFOPOI')
  202.           IF (ipar.GT.0) THEN
  203.             ifopo = CHAPAR.CPARVL(ipar)
  204.           ENDIF
  205.         ENDIF
  206.  
  207. C-----Definition des composantes et de l'harmonique (si existe)
  208.         ncomp = CHAINF.CNAME(/2)
  209.         nnin  = nnin + ncomp
  210.         SEGADJ MTRAV
  211.       if (iimpi.eq.1972) then
  212.         write(ioimp,*)' -',(CHAINF.CNAME(ib)(1:LOCHPO)//'-',ib=1,ncomp)
  213.       endif
  214.  
  215. C Determination du FORMAT automatique
  216.         IFORMA = INT(LOG10(REAL(ncomp))) + 1
  217.         IF (IFORMA.LT.1 .AND. IFORMA.GT.7) THEN
  218.           CALL ERREUR(1094)
  219.           RETURN
  220.         ENDIF
  221.         WRITE(cha4F(3:3),'(I1)') IFORMA
  222.  
  223.         DO ib = 1, ncomp
  224.           cha8a = CHAINF.CNAME(ib)(1:LOCHPO)
  225.           IF (cha8a .EQ. '        ') THEN
  226.             cha8a = 'SCAL    '
  227.             CHAINF.CNAME(ib) = cha8a
  228.           ENDIF
  229.           CALL PLACE(MTRAV.INCO, innin, iamot, cha8a)
  230.           IF (iamot .EQ. 0) THEN
  231.             innin = innin + 1
  232.             MTRAV.INCO(innin) = cha8a
  233. C-- recuperation de l'harmonique si donne via les parametres du champ
  234.             IF (ncpars .GT. 0) THEN
  235.               cha16b = 'NOHARM          '
  236.               WRITE(cha16b(6+1:6+IFORMA), cha4F) ib
  237.               CALL PLACE(CHAPAR.CPARNM, ncpars, ibmot, cha16b)
  238.               IF (ibmot .GT. 0) THEN
  239.                 MTRAV.NHAR(innin) = CHAPAR.CPARVL(ibmot)
  240.               ENDIF
  241.             ENDIF
  242.           ENDIF
  243.  
  244.         ENDDO
  245.  
  246.         IF (innin .NE. nnin) THEN
  247.           nnin = innin
  248.           SEGADJ,MTRAV
  249.         ENDIF
  250.  
  251. C-----Definition de la geometrie
  252.         nprof = CHAPRO.CETYPE(/1)
  253.         DO ib=1,nprof
  254.           pname = CHAPRO.CPRONA(ib)
  255.           IF (pname .NE. ' ') THEN
  256.             typobj = '        '
  257.             CALL ACCTAB(MTABLE,'MOT',ival,xval,pname,login,iobin,
  258.      &                  typobj,ivalre,xvalre,charre,logre,iobre)
  259.  
  260.             IF ((iobre .LE. 0) .OR. (typobj .NE. 'MAILLAGE')) THEN
  261. C-------------Lecture de la taille d'un profil dont on connait le nom
  262.               CALL mpfpsn(MFID, pname, mpsize, mcret)
  263.               IF (mcret .NE. 0) THEN
  264.                 moterr    = 'lmdchp / mpfpsn'
  265.                 interr(1) = mcret
  266.                 CALL ERREUR(873)
  267.                 RETURN
  268.               ENDIF
  269.               nsize=mpsize
  270.               IF (nsize .EQ. 0) THEN
  271.                 CALL ERREUR(21)
  272.                 RETURN
  273.               ENDIF
  274.               STPROF.LTPROF(ia, ib) = nsize
  275.               nnnoe  = nnnoe + nsize
  276.               SEGADJ MTRAV
  277.  
  278. * OF Optimisation possible en supprimant SPROFI
  279.               SEGINI,SPROFI
  280.               CALL mpfprr(MFID, pname, SPROFI.LPROFI, mcret)
  281.               IF (mcret .NE. 0) THEN
  282.                 moterr(1:6) = 'lmdchp / mpfprr'
  283.                 interr(1)   = mcret
  284.                 CALL ERREUR(873)
  285.                 RETURN
  286.               ENDIF
  287.               DO ic = 1, nsize
  288.                 innoe = innoe + 1
  289.                 MTRAV.IGEO(innoe)=SPROFI.LPROFI(ic) + NBNOIN
  290.               ENDDO
  291.               SEGSUP,SPROFI
  292.  
  293.             ELSE
  294. C-------------On cherche directement dans le maillage
  295.               MELEME = iobre
  296.               CALL CHANGE(meleme, 1)
  297.               SEGACT,MELEME
  298.               nbnode = MELEME.NUM(/2)
  299.               IF (nbnode .EQ. 0) THEN
  300.                 CALL ERREUR(21)
  301.                 RETURN
  302.               ENDIF
  303.  
  304.               STPROF.LTPROF(ia, ib) = nbnode
  305.               nnnoe  = nnnoe + nbnode
  306.               SEGADJ MTRAV
  307.               DO ic=1,nbnode
  308.                 innoe = innoe + 1
  309.                 MTRAV.IGEO(innoe) = MELEME.NUM(1,ic)
  310.               ENDDO
  311.               SEGDES MELEME
  312.             ENDIF
  313.  
  314.           ELSE
  315.             IF (nprof .NE. 1) THEN
  316.               CALL ERREUR(21)
  317.               RETURN
  318.             ENDIF
  319.             typobj = 'MAILLAGE'
  320.             CALL ACCTAB(MTABLE,'MOT     ',ival,xval,nommai,login,iobin,
  321.      &                         typobj,ivalre,xvalre,charre,logre,iobre)
  322.             IF (IERR.NE.0) RETURN
  323.  
  324. C----------- On cherche tous les points dans un maillage POI1
  325.             MELEME = iobre
  326.             CALL CHANGE(meleme, 1)
  327.             SEGACT,MELEME
  328.             nbnode = MELEME.NUM(/2)
  329.             IF (nbnode .EQ. 0) THEN
  330.               CALL ERREUR(21)
  331.               RETURN
  332.             ENDIF
  333.             STPROF.LTPROF(ia, ib) = nbnode
  334.             nnnoe = nnnoe + nbnode
  335.             SEGADJ MTRAV
  336.             DO ic = 1, nbnode
  337.               innoe = innoe + 1
  338. c**              MTRAV.IGEO(innoe) = MELEME.NUM(1,ic)
  339.               MTRAV.IGEO(innoe) = ic + NBNOIN
  340.             ENDDO
  341.             SEGDES,MELEME
  342.           ENDIF
  343.         ENDDO
  344.       ENDDO
  345. C-FIN-1----Definition initiale de MTRAV
  346.  
  347. C-----Definition des valeurs
  348.       innoe = 0
  349.       DO ia=1,nbfus
  350.         icha   = SLSFUS.CHAFUS(ia)
  351.         fname  = SLSCHA.LISCHA(icha)
  352. C        nommai = SLSCHA.LISMAI
  353.         CHAINF = SLSCHA.LSCHIN(icha)
  354.         CHAPRO = CHAINF.ISCHPR(IPDT)
  355.         nprof  = CHAPRO.CETYPE(/1)
  356.         numdt  = CHAINF.INUMDT(IPDT)
  357.         numit  = CHAINF.INUMIT(IPDT)
  358.         ncomp  = CHAINF.CNAME(/2)
  359.  
  360.         SEGINI MCNAM8
  361.         DO ib = 1, ncomp
  362.           MCNAM8.CNAME8(ib) = CHAINF.CNAME(ib)(1:LOCHPO)
  363.         ENDDO
  364.  
  365.         DO ib = 1, nprof
  366.           pname = CHAPRO.CPRONA(ib)
  367.       if (iimpi.eq.1972) then
  368.         write(ioimp,*) 'boucle ib',ib,nprof,pname
  369.       endif
  370.           IF (pname .NE. ' ') THEN
  371. C-----------Lecture du nombre de valeurs a lire dans un champ pour une sequence de calcul,
  372. C           et un type d'entite donnes pour un profil donne
  373.             it = ib
  374.             CALL mfdnvp(MFID, fname, numdt, numit, metype, mgtype, it,
  375.      &                  mtsf, pname, mpsize, lname, nval, n4, mcret)
  376.             IF (mcret .NE. 0) THEN
  377.               moterr    = 'lmdchp / mfdnvp'
  378.               interr(1) = mcret
  379.               CALL ERREUR(873)
  380.               RETURN
  381.             ENDIF
  382.             nbnode = mpsize
  383.             SEGINI,SCHAVL
  384.  
  385. C-----------Lecture des valeurs d'un champ definies sur des entites d'un maillage 
  386. C           pour une sequence de calcul et un profil donnes
  387.             CALL mfdrpr(MFID, fname, numdt, numit, metype, mgtype,
  388.      &                  mtsf, pname, mswm, mcs, SCHAVL.CHAVAL, mcret)
  389.             IF (mcret .NE. 0) THEN
  390.               moterr    = 'lmdchp / mfdrpr'
  391.               interr(1) = mcret
  392.               CALL ERREUR(873)
  393.               RETURN
  394.             ENDIF
  395.  
  396.           ELSE
  397. C-----------Lecture du nombre de valeurs dans un champ pour une sequence de calcul,
  398. C           et un type d'entite donnes (pas de gestion des profils)
  399.             CALL mfdnva(MFID, fname, numdt, numit,
  400.      &                  metype, mgtype, n4, mcret)
  401.             IF (mcret .NE. 0) THEN
  402.               moterr    = 'lmdchp / mfdnva'
  403.               interr(1) = mcret
  404.               CALL ERREUR(873)
  405.               RETURN
  406.             ENDIF
  407.             nbnode = STPROF.LTPROF(ia, ib)
  408.             SEGINI SCHAVL
  409.  
  410. C-----------Lecture des valeurs d'un champ definies sur des entites d'un maillage 
  411. C           pour une sequence de calcul donnee (pas de gestion de profil)
  412.             CALL mfdrvr(MFID, fname, numdt, numit, metype, mgtype,
  413.      &                  mswm, mcs, SCHAVL.CHAVAL, mcret)
  414.             IF (mcret .NE. 0) THEN
  415.               moterr    = 'lmdchp / mfdrvr'
  416.               interr(1) = mcret
  417.               CALL ERREUR(873)
  418.               RETURN
  419.             ENDIF
  420.           ENDIF
  421.  
  422. C         Ecriture des valeurs dans le MTRAV pour creer le CHPOINT
  423.           IF (nbnode .GT. MTRAV.IBIN(/2))THEN
  424.             NNIN  = MTRAV.IBIN(/1)
  425.             NNNOE = nbnode
  426.             SEGADJ,MTRAV
  427.           ENDIF
  428.  
  429.           inno2 = innoe
  430.           DO ic=1,nnin
  431.             innoe = inno2
  432.             CALL PLACE(MCNAM8.CNAME8, ncomp, iamot, MTRAV.INCO(ic))
  433.             DO ie=1,nbnode
  434.               innoe = innoe + 1
  435.               IF (iamot .GT. 0) THEN
  436.                 MTRAV.BB  (ic, innoe) = SCHAVL.CHAVAL(ie, iamot)
  437.                 MTRAV.IBIN(ic, innoe) = 1
  438.               ELSE
  439.                 MTRAV.BB  (ic, innoe) = 0.D0
  440.                 MTRAV.IBIN(ic, innoe) = 0
  441.               ENDIF
  442.             ENDDO
  443.           ENDDO
  444.           SEGSUP SCHAVL
  445.         ENDDO
  446.       ENDDO
  447.  
  448.       CALL CRECHP(MTRAV, MCHPOI)
  449.       SEGSUP MTRAV,STPROF
  450.       IF (MCHPOI .LE. 0) THEN
  451.         CALL ERREUR(21)
  452.         RETURN
  453.       ENDIF
  454.  
  455.       MCHPOI.MOCHDE    = 'CHPOINT cree par LIRMED'
  456.       MCHPOI.JATTRI(1) = ijatt
  457.       MCHPOI.IFOPOI    = ifopo
  458.       SEGACT MCHPOI*NOMOD
  459.       ISOR = MCHPOI
  460.  
  461. c      return
  462.       END
  463.  
  464.  
  465.  

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