Télécharger la plaquette Cast3M


fr en

Télécharger lirmed.eso

Retour à la liste

Numérotation des lignes : 

lirmed

  1. C LIRMED    SOURCE    OF166741  24/03/28    21:15:03     11811          
  2.  
  3. C***********************************************************************
  4. C NOM         : lirmed.eso
  5. C DESCRIPTION : Sortie d'un maillage au format .med
  6. C***********************************************************************
  7. C HISTORIQUE :  21/12/2010 : CHAT     : creation de la subroutine
  8. C HISTORIQUE :  04/11/2013 : CB215821 : PASSAGE AU FORMAT 3.0 DE MED
  9. C HISTORIQUE :  05/01/2017 : CB215821 : GESTION DES ERREURS DE LECTURE
  10. C HISTORIQUE :  23/10/2017 : RPAREDES : LECTURE CHPOINT,MCHAML,PASAPAS
  11. C HISTORIQUE :  09/10/2018 : BERTHINC : SOUCIS SI TASSPO dans PARAVIS
  12. C HISTORIQUE :  28/20/2019 : BERTHINC : PASSAGE AU FORMAT 4.0 DE MED
  13. C HISTORIQUE :  25/11/2022 : OF       : AMELIORATIONS LECTURE DES POINTS
  14. C HISTORIQUE :  25/11/2022 : OF       : LECTURE D'UN SEUL MAILLAGE MED
  15. C HISTORIQUE :  25/11/2022 : OF       : MEILLEURE GESTION DES SEGMENTS
  16. C HISTORIQUE :  25/11/2022 : OF       : AJOUT LECTURE POLYGONES
  17. C HISTORIQUE :  10/01/2024 : OF       : QUELQUES AMELIORATIONS
  18. C HISTORIQUE :  22/01/2024 : OF       : QUELQUES AMELIORATIONS (2)
  19. C HISTORIQUE :  31/01/2024 : OF       : QUELQUES MODIFICATIONS
  20. C HISTORIQUE :  12/02/2024 : OF       : PASSAGE A LA VERSION MED 64B
  21. C***********************************************************************
  22. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  23. C en cas de modification de ce sous-programme afin de faciliter
  24. C la maintenance !
  25. C***********************************************************************
  26. C APPELE PAR : operateur LIRE (lirefi.eso)
  27. C***********************************************************************
  28. C ENTREES : aucune
  29. C SORTIES : aucune
  30. C***********************************************************************
  31. C SYNTAXE (GIBIANE) :
  32. C
  33. C    TAB1 = LIRE 'MED' 'fichier.med' ;
  34. C
  35. C***********************************************************************
  36.  
  37.       SUBROUTINE LIRMED
  38.  
  39.       IMPLICIT INTEGER(i-n)
  40.       IMPLICIT REAL*8(a-h,o-z)
  41.  
  42. -INC PPARAM
  43. -INC CCOPTIO
  44. -INC CCGEOME
  45. -INC CCMED
  46.  
  47. -INC SMCOORD
  48. -INC SMELEME
  49. -INC SMTABLE
  50. -INC SMMED
  51.  
  52. C Definition des reels *8
  53.       REAL*8    dt
  54.  
  55. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  56.       CHARACTER*(MED_SNAME_SIZE) dtunit
  57.  
  58. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  59.       CHARACTER*(MED_NAME_SIZE) name
  60.       CHARACTER*(MED_NAME_SIZE) fam
  61.       CHARACTER*(MED_NAME_SIZE) fname
  62.       CHARACTER*(MED_NAME_SIZE) mname
  63.       CHARACTER*(MED_NAME_SIZE) dname
  64.  
  65. C-----Chaines de Caractere de longueur MED_LNAME_SIZE=80
  66.       CHARACTER*(MED_LNAME_SIZE) char80
  67.  
  68. C-----Chaines de Caractere de longueur MED_COMMENT_SIZE=200
  69.       CHARACTER*(MED_COMMENT_SIZE) desc
  70. C ***** FIN
  71.  
  72. C ***** Declaration des variables
  73.       CHARACTER*8   cha8b, charin,charre, typobj,typmot
  74.       CHARACTER*64  cha64a, cha64b
  75.       LOGICAL       ltelq, login, logre
  76.       CHARACTER*(LOCHAI) medres,medmai
  77.       EXTERNAL LONG
  78.  
  79. C ***** Declaration des segments
  80.       SEGMENT SAWORK
  81.         CHARACTER*(MED_SNAME_SIZE) ANAME(jdim)
  82.         CHARACTER*(MED_SNAME_SIZE) AUNIT(jdim)
  83.       ENDSEGMENT
  84.  
  85. C-----Contiendra les MAILLAGES SIMPLES au sens de Cast3M
  86. C       ntypel ==> Type d'element au sens de Cast3M
  87. C       IPOMAI ==> pointeur MAILLAGE SIMPLE
  88. C       INUMLI ==> pointeur vers le tableau des numeros de famille de chaque element
  89.       SEGMENT MAITOT
  90.         INTEGER IPOMAI(ntypel)
  91.         INTEGER INUMLI(ntypel)
  92.       ENDSEGMENT
  93.  
  94. C-----Contiendra les numeros des familles des noeuds
  95.       SEGMENT NUMLI8
  96.         INTEGER NUMLIS(nbelem)
  97.       ENDSEGMENT
  98.       POINTEUR LFPOLY.NUMLI8
  99.  
  100. C-----SEGMENT contenant les informations sur les familles
  101. C       infam  ==> Indice de la famille
  102. C       IFAMNU ==> Numero de la famille
  103. C       PFAMGR ==> Pointeur vers le SEGMENT SFAMGR : nom des groupes dans la famille
  104. C       CFANOM ==> Nom de la famille
  105. C       PFAMAI ==> Pointeur vers MELEME de la famille en question
  106.       SEGMENT SFAMI
  107.         INTEGER                   IFAMNU(infam)
  108.         INTEGER                   PFAMGR(infam)
  109.         CHARACTER*(MED_NAME_SIZE) CFANOM(infam)
  110.         INTEGER                   PFAMAI(infam)
  111.       ENDSEGMENT
  112.  
  113. C-----SEGMENT contenant les noms des groupes
  114.       SEGMENT SFAMGR
  115.         CHARACTER*(MED_LNAME_SIZE) CFGRN(ngroup)
  116.       ENDSEGMENT
  117.  
  118. C-----SEGMENT contenant les groupes de noms differents (Casse comprise)
  119. C       CGRNOM  ==> Nom des groupes differents
  120.       SEGMENT SGRTOT
  121.         CHARACTER*(MED_NAME_SIZE) CGRNOM(ngrdif)
  122.       ENDSEGMENT
  123. C-- SEGMENT qui contiendra le nom de tous les maillages du fichier
  124.       POINTEUR LINOMA.SGRTOT
  125.  
  126.       SEGMENT ICOOR
  127.         REAL*8 XCOO(isdim,nbpta)
  128.       ENDSEGMENT
  129.  
  130.       SEGMENT SINT4
  131.         INTEGER INT4(itaill)
  132.       ENDSEGMENT
  133.       POINTEUR LMAIL2.SINT4,LPOLY.SINT4,LINDP.SINT4,LCONP.SINT4
  134.  
  135. C----- SEG SLSCHA
  136. C         LSNMAI : nom du maillage
  137. C         ncham  : nombre de champs (CHPOINT ou MCHAML)
  138. C         LSNCHA : liste des noms de champs
  139. C         LSCHIN : liste de SEG CHAINF (information)
  140. C         LSPARA : liste de SEG CHAPAR (parametres)
  141.       SEGMENT SLSCHA
  142.         CHARACTER*(MED_NAME_SIZE) LSNMAI
  143.         CHARACTER*(MED_NAME_SIZE) LSNCHA(ncham)
  144.         INTEGER                   LSCHIN(ncham), LSPARA(ncham)
  145.       ENDSEGMENT
  146.  
  147. C----- SEG SLSSOR
  148. C         nbsor  : nombre de champs a sortir
  149. C         CHATYP : type de champ (CHPOINT, MCHAML ou TABLE)
  150. C         CHANOM : nom du champ
  151. C         CHALIS : liste de champs dans un segment SLSFUS(CHPOINT ou MCHAML)
  152. C                  ou SLSSOR(TABLE)
  153.       SEGMENT SLSSOR
  154.         CHARACTER*8               CHATYP(nbsor)
  155.         CHARACTER*(MED_NAME_SIZE) CHANOM(nbsor)
  156.         INTEGER                   CHALIS(nbsor)
  157.       ENDSEGMENT
  158.       POINTEUR SLSSO1.SLSSOR
  159.  
  160.       SEGMENT SLSFUS
  161.         INTEGER      CHAFUS(nbfus)
  162.       ENDSEGMENT
  163.  
  164.       SEGMENT CHAINF
  165. C         nseq   :   nombre de sequences de calcul dans le champ
  166. C         ncomp  :   nombre de composantes
  167. C         INUMDT :   liste de numeros de pas de tps
  168. C         INUMIT :   liste de numeros d'iteration
  169. C         ISCHPR :   liste de SEG CHAPRO (profil)
  170. C         XDT    :   liste de pas de tps
  171. C         CNAME  :   liste de noms des composants
  172. C         CUNIT  :   liste d'unites des composants
  173.         INTEGER      INUMDT(nseq), INUMIT(nseq), ISCHPR(nseq)
  174.         REAL*8       XDT(nseq)
  175.         CHARACTER*(MED_SNAME_SIZE) CNAME(ncomp), CUNIT(ncomp)
  176.       ENDSEGMENT
  177.  
  178. C----- SEG CHAPAR
  179. C         ncpars : nombre de parametres par champ
  180. C         CHAPAR : nom du parametre
  181. C         CPARVL : valeur du parametre
  182.       SEGMENT CHAPAR
  183.         CHARACTER*(MED_SNAME_SIZE) CPARNM(ncpars)
  184.         INTEGER                    CPARVL(ncpars)
  185.       ENDSEGMENT
  186.  
  187. C----- SEG CHAPRO
  188. C         nprof  : nombre de profils
  189. C         CTYPE  : type de champ
  190. C         CPRONA : nom du profil
  191. C         CETYPE : entity type
  192. C         CGTYPE : geometry type
  193.       SEGMENT CHAPRO
  194.         CHARACTER*8               CTYPE(nprof)
  195.         CHARACTER*(MED_NAME_SIZE) CPRONA(nprof)
  196.         INTEGER                   CETYPE(nprof), CGTYPE(nprof)
  197.       ENDSEGMENT
  198.  
  199. C----- SEG LISPRO
  200. C         ntprof : nombre total de profils
  201. C         DPNAME : nom du profil
  202. C         LNAME  : localisation du profil
  203.       SEGMENT LISPRO
  204.         CHARACTER*(MED_NAME_SIZE) DPNAME(ntprof), LNAME(ntprof)
  205.       ENDSEGMENT
  206.  
  207.       if (iimpi.EQ.1972) then
  208.         write(ioimp,*)
  209.         write(ioimp,*) 'Entree dans LIRE "MED"'
  210.         write(ioimp,*) '----------------------'
  211.       endif
  212. C***********************************************************************
  213. C* 0 - Initialisations (pour retour a etat de depart en cas d'erreur)
  214. C***********************************************************************
  215.       SEGACT,MCOORD*MOD
  216.       IDIM_REF  = IDIM
  217.       NBPTS_REF = NBPTS
  218.  
  219.       MEDTAB = 0
  220.       MTABLE = 0
  221.  
  222.       typmot = 'MOT     '
  223.  
  224. C***********************************************************************
  225. C* 1 - Lecture des arguments et options de 'LIRE' 'MED'
  226. C***********************************************************************
  227. C* 1.1 - Nom du fichier MED
  228.       medres = ' '
  229.       ilores = 0
  230.  
  231.       icond = 1
  232.       CALL LIRCHA(medres, icond, iretou)
  233.       IF (IERR.NE.0) GOTO 9999
  234.       ilores = LONG(medres)
  235.  
  236. C* 1.2 - Nom du maillage a lire, numero du maillage a lire (par defaut tous)
  237. C*       Cas particulier : obtention du nom de tous les maillages si 0 est lu
  238.       IMEDMA = -3
  239.       medmai = ' '
  240.       ilomai = 0
  241.  
  242.       icond = 0
  243.       CALL LIRCHA(medmai, icond, iretou)
  244.       IF (IERR.NE.0) GOTO 9999
  245.       IF (iretou.GT.0) THEN
  246.         ilomai = LONG(medmai)
  247.         IF (ilomai.GT.MED_NAME_SIZE) THEN
  248.           moterr = 'Nom du maillage trop long pour MED'
  249.           CALL ERREUR(-385)
  250.           CALL ERREUR(21)
  251.         ELSE IF (ilomai.LT.1) THEN
  252.           moterr = 'Nom du maillage de taille nulle'
  253.           CALL ERREUR(-385)
  254.           CALL ERREUR(21)
  255.         ENDIF
  256.       if (iimpi.eq.1972) then
  257.         write(ioimp,*) 'MEDMAI=',medmai(1:ilomai),'='
  258.       endif
  259.         IF (IERR.NE.0) GOTO 9999
  260.         IMEDMA = -1
  261.       ELSE
  262.         CALL LIRENT(ia, icond, iretou)
  263.         IF (IERR.NE.0) GOTO 9999
  264.         IF (iretou.GT.0) THEN
  265.           IF (ia.LT.0) THEN
  266.             interr(1) = ia
  267.             CALL ERREUR(36)
  268.             GOTO 9999
  269.           END IF
  270.           IMEDMA = ia
  271.         ENDIF
  272.       ENDIF
  273.  
  274. C***********************************************************************
  275. C* 2 - Ouverture du fichier - Debut de la lecture
  276. C***********************************************************************
  277. C *** Initialisation du code de retour (=0 si OK, probleme sinon)
  278.       mcret = 0
  279.  
  280. C *** Ouverture d'un fichier MED
  281.       macces = MED_ACC_RDONLY
  282.       CALL MFIOPE(mfid, medres(1:ilores), macces, mcret)
  283.       IF (mcret .NE. 0) THEN
  284.         moterr    = 'lirmed / mfiope'
  285.         interr(1) = mcret
  286.         CALL ERREUR(873)
  287.         GOTO 9999
  288.       ENDIF
  289.  
  290. C *** Verification de la compatibilite d'un fichier avec HDF et MED
  291.       CALL MFICOM(medres(1:ilores), hdfok, medok, mcret)
  292.       IF (mcret .NE. 0) THEN
  293.         moterr    = 'lirmed / mficom'
  294.         interr(1) = mcret
  295.         CALL ERREUR(873)
  296.         GOTO 9998
  297.       ENDIF
  298. C *** Lecture du numero de version de la bibliotheque MED utilisee pour creer le fichier
  299.       CALL MFINVR(mfid, major, minor, mrele, mcret)
  300.       IF (mcret .NE. 0) THEN
  301.         moterr    = 'lirmed / mfinvr'
  302.         interr(1) = mcret
  303.         CALL ERREUR(873)
  304.         GOTO 9998
  305.       ENDIF
  306.       if (iimpi.EQ.1972) then
  307.         write(moterr,'(A,I2,A,I2,A,I2)')
  308.      &          'Read MED file version ',major,'.',minor,'.',mrele
  309.         call erreur(-385)
  310.       endif
  311. C *** On ne sait pas lire du MED anterieur a 3
  312.       IF (major .LT. 3) THEN
  313.         write(moterr,'(A,I2,A,I2,A,I2)')
  314.      &           'Bad MED file version ',major,'.',minor,'.',mrele
  315.         CALL ERREUR(-385)
  316.         interr(1) = 9999
  317.         CALL ERREUR(21)
  318.         GOTO 9998
  319.       ENDIF
  320.  
  321. C *** Lecture du nombre de maillages dans le fichier MED
  322.       CALL MMHNMH(mfid, nbmail, mcret)
  323.       IF (mcret .NE. 0) THEN
  324.         moterr     = 'lirmed / mmhnmh'
  325.         interr(1)  = mcret
  326.         CALL ERREUR(873)
  327.         GOTO 9998
  328.       ENDIF
  329.       if (iimpi.EQ.1972) then
  330.         write(ioimp,*) 'Nombre de maillages du fichier',nbmail
  331.       endif
  332.  
  333. C ***** Nombre de champs a lire
  334.       CALL mfdnfd(mfid, nbcham, mcret)
  335.       IF (mcret .NE. 0) THEN
  336.         moterr    = 'lirmed / mfdnfd'
  337.         interr(1) = mcret
  338.         CALL ERREUR(873)
  339.         GOTO 9998
  340.       ENDIF
  341.       if (iimpi.EQ.1972) then
  342.         write(ioimp,*) 'Nombre de champs du fichier',nbcham
  343.       endif
  344.  
  345. C ***** Recherche des parametres numeriques
  346.       CALL mprnpr(mfid, nparam, mcret)
  347.       IF (mcret .NE. 0) THEN
  348.         moterr    = 'lirmed / mprnpr'
  349.         interr(1) = mcret
  350.         CALL ERREUR(873)
  351.         GOTO 9998
  352.       ENDIF
  353.       if (iimpi.EQ.1972) then
  354.         write(ioimp,*) 'Nombre de parametres numeriques',nparam
  355.       endif
  356.  
  357. C ***** Nombre de profils
  358.       CALL mpfnpf(mfid, n4, mcret)
  359.       IF (mcret .NE. 0) THEN
  360.         moterr    = 'lirmed / mpfnpf'
  361.         interr(1) = mcret
  362.         CALL ERREUR(873)
  363.         GOTO 9998
  364.       ENDIF
  365.       ntprof = n4
  366.       ntprof = MAX(ntprof,1)
  367.       if (iimpi.EQ.1972) then
  368.         write(ioimp,*) 'Nombre de profils',ntprof,n4
  369.       endif
  370.  
  371. C***********************************************************************
  372. C* 3 - Quelques premieres initialisations et verifications
  373. C***********************************************************************
  374. C- Pour la table
  375.       inin  = 0
  376.       inre  = 0
  377.       login = .FALSE.
  378.       logre = .FALSE.
  379.       floin = 0.D0
  380.       flore = 0.D0
  381.       charin = '    '
  382.       charre = '    '
  383.  
  384.       SAWORK = 0
  385.       jdim   = 3
  386.       SEGINI,SAWORK
  387.       DO ii = 1, jdim
  388.         SAWORK.ANAME(ii) = '    '
  389.         SAWORK.AUNIT(ii) = '    '
  390.       END DO
  391.  
  392. C- Recherche et stockage du nom de tous les maillages du fichier
  393. C- On verifie qu'il n'y a pas redondance des noms.
  394.       LINOMA = 0
  395.       ngrdif = nbmail
  396.       SEGINI,LINOMA
  397.       isdim = 0
  398.       DO imel = 1, nbmail
  399.         LINOMA.CGRNOM(imel) = ' '
  400.         name = ' '
  401.         it   = imel
  402.         CALL MMHMII(mfid, it, name, msdim, mmdim, mmtype, desc, dtunit,
  403.      &                  mstype, nstep, matype, ANAME, AUNIT, mcret)
  404.       if (iimpi.EQ.1972) then
  405.         write(ioimp,*) '1) sdim,mtype,mdim,stype,nstep,atype lus :',
  406.      &                  msdim,mmtype,mmdim,mstype,nstep,matype
  407.         write(ioimp,*) (ANAME(i),AUNIT(i),i=1,jdim)
  408.       endif
  409.         IF (mcret .NE. 0) THEN
  410.           moterr    = 'lirmed / mmhmii'
  411.           interr(1) = mcret
  412.           CALL ERREUR(873)
  413.           GOTO 9997
  414.         ENDIF
  415.         if (msdim.le.0) then
  416.           moterr    = 'lirmed / mmhmii / msdim'
  417.           interr(1) = msdim
  418.           call erreur(873)
  419.           goto 9997
  420.         endif
  421.         LINOMA.CGRNOM(imel) = name
  422.         ilm = LONG(name)
  423.         moterr = '    : Mesh name "'//name(1:ilm)//'"'
  424.         write(moterr(2:4),'(I3)') imel
  425.         ilm = LONG(moterr)
  426.       if (iimpi.EQ.1972) then
  427.         CALL ERREUR(-385)
  428.       endif
  429.         DO ii = 1, imel-1
  430.           IF (name .EQ. LINOMA.CGRNOM(ii)) THEN
  431.             moterr = moterr(1:ilm)//' already defined !'
  432.             CALL ERREUR(-385)
  433.             CALL ERREUR(21)
  434.             GOTO 9997
  435.           END IF
  436.         END DO
  437.         ii = msdim
  438.         isdim = MAX(isdim, ii)
  439.       ENDDO
  440.       if (iimpi.EQ.1972) then
  441.         write(ioimp,*) 'SDIM',isdim
  442.         moterr = ' '
  443.         call erreur(-385)
  444.       endif
  445.  
  446. C***********************************************************************
  447. C* 4 - Cas particuliers : - On ne souhaite que la liste des maillages
  448. C*                        - On veut tous les maillages et leur nombre =0
  449. C***********************************************************************
  450.       IF (IMEDMA.EQ.0) THEN
  451.       if (iimpi.eq.1972) then
  452.         moterr = 'Nombre de maillages dans le fichier'
  453.         write(moterr(36:39),fmt='(I4)') nbmail
  454.         call erreur(-385)
  455.       endif
  456.         m = nbmail
  457.         SEGINI,MTABLE
  458.         typobj = 'ENTIER  '
  459.         DO imel = 1, nbmail
  460.           name = LINOMA.CGRNOM(imel)
  461.           ilm  = LONG(name)
  462.           CALL ECCTAB(MTABLE,typobj,imel,floin,charin(1:1),
  463.      &                              login,inin,
  464.      &                       typmot,inre,flore,name(1:ilm),
  465.      &                              logre,inre)
  466.         ENDDO
  467.       if (iimpi.EQ.1972) then
  468.         write(ioimp,*)
  469. c#DBG        moterr = ' '
  470. c#DBG        CALL ERREUR(-385)
  471.       endif
  472.         MEDTAB = MTABLE
  473.         GOTO 9997
  474.       ENDIF
  475.  
  476.       IF (IMEDMA.EQ.-3 .AND. nbmail.EQ.0) THEN
  477.         m = 0
  478.         SEGINI,MTABLE
  479.         MEDTAB = MTABLE
  480.         GOTO 9997
  481.       ENDIF
  482.  
  483. C***********************************************************************
  484. C* 5 -  Recherche du maillage si demande (son nom sera dans medmai).
  485. C*      Par defaut, on lira tous les maillages.
  486. C***********************************************************************
  487. C 5.1 - Le nom du maillage est donne, on verifie s'il existe dans le 
  488. C       fichier dont la liste des maillages est maintenant connu, on 
  489. C       a alors l'indice du maillage imel_i = imel_f = indice_de_medmai
  490.       IF (IMEDMA.EQ.-1) THEN
  491.         imel_i = 0
  492.         DO imel = 1, nbmail
  493.           name = LINOMA.CGRNOM(imel)
  494.           ilm = LONG(name)
  495.       if (iimpi.EQ.1972) then
  496.         write(ioimp,*) 'Traitement du maillage ',imel,' / ',nbmail
  497.         write(ioimp,*) 'name=',name(1:ilm),'='
  498.       endif
  499.           IF (name(1:ilm).EQ.medmai(1:ilomai)) THEN
  500.             IF (imel_i.NE.0) THEN
  501.               write(ioimp,*) 'Maillage deja trouve',imel_i,'<-',imel
  502.               CALL ERREUR(21)
  503.               GOTO 9997
  504.             ENDIF
  505.             imel_i = imel
  506.           ENDIF
  507.         ENDDO
  508.         IF (imel_i.EQ.0) THEN
  509.           moterr = 'Maillage/Mesh "'//medmai(1:ilomai)//
  510.      &             '" non trouve/not found'
  511.           CALL ERREUR(-385)
  512.           CALL ERREUR(21)
  513.           GOTO 9997
  514.         ENDIF
  515.         imel_f = imel_i
  516.         IMEDMA = imel_i
  517. C 5.2 - On veut relire tous les maillages du fichier, boucle sur les 
  518. C       indices des maillages seront de imel_i = 1 a imel_f = nbmail 
  519.       ELSE IF (IMEDMA .EQ. -3) THEN
  520.         imel_i = 1
  521.         imel_f = nbmail
  522. C 5.3 - L'indice du maillage est donne, on verifie s'il est coherent 
  523. C       avec le nombre de maillages du fichier et on recupere alors
  524. C       son nom (dans medmai) et imel_i = imel_f = IMEDMA
  525.       ELSE
  526.         IF (IMEDMA.LT.1 .OR. IMEDMA.GT. nbmail) THEN
  527.           moterr = 'Mesh number "   " not found'
  528.           write(moterr(14:16),'(I3)') IMEDMA
  529.           CALL ERREUR(-385)
  530.           CALL ERREUR(21)
  531.           GOTO 9997
  532.         ENDIF
  533.         imel_i = IMEDMA
  534.         imel_f = imel_i
  535. C-------Recuperation du nom du maillage
  536.         name = LINOMA.CGRNOM(imel_i)
  537.         ilomai = LONG(name)
  538.         medmai(1:ilomai) = name(1:ilomai)
  539.       ENDIF
  540.  
  541. C***********************************************************************
  542. C* 6 - Dimension du ou des maillages a lire
  543. C***********************************************************************
  544.       imdim = 0
  545.       DO imel = imel_i, imel_f
  546.         it = imel
  547. C---Lecture du nombre d'axes du repere des coordonnees du maillage
  548.         CALL MMHNAX(mfid, it, n4, mcret)
  549.         IF (mcret .NE. 0) THEN
  550.           moterr    = 'lirmed / mmhnax'
  551.           interr(1) = mcret
  552.           CALL ERREUR(873)
  553.           GOTO 9997
  554.         ENDIF
  555.         ii = n4
  556.         imdim = MAX(imdim, ii)
  557.       ENDDO
  558.       if (iimpi.EQ.1972) then
  559.         write(ioimp,*) '6) IMDIM =',imdim
  560.       endif
  561.  
  562. C---Changement de la dimension de l'espace en cas de necessite
  563. C---J'utilise le GIBIANE pour le faire : "OPTI DIME imdim ;"
  564.       IF (IDIM .LT. imdim) THEN
  565.         CALL ECRENT(imdim)
  566.         CALL ECRCHA('DIME')
  567.         CALL OPTION(1)
  568.  
  569.         IF (IERR .NE. 0) THEN
  570.           moterr = 'LIRE MED - ERREUR de changement de DIMEnsion'
  571.           CALL ERREUR(-385)
  572.           CALL ERREUR(219)
  573.           GOTO 9997
  574.         ENDIF
  575.  
  576.         moterr = ' '
  577.         CALL ERREUR(-385)
  578.         moterr = 'Passage en DIMEnsion   '
  579.         write(moterr(22:22),'(I1)') imdim
  580.         CALL ERREUR(-385)
  581.         moterr = ' '
  582.         CALL ERREUR(-385)
  583.  
  584.         SEGACT,MCOORD*MOD
  585.       ENDIF
  586.       IDIMP1 = IDIM + 1
  587.  
  588. C***********************************************************************
  589. C* 7 - Initialisations
  590. C***********************************************************************
  591. C* 7.1 - On initialise la table (au minimum N maillages et N maillages de POI1) 
  592.       m = 2 * (imel_f - imel_i + 1)
  593.       SEGINI,MTABLE
  594.  
  595.       ltelq = .TRUE.
  596.  
  597. C* 7.2 - Quelques segments locaux :
  598. C- (legerement surdimensionnes pour ne les definir q'une seule fois)
  599. C- ntypol = MED_MAXCPO pour les polygones ayant de 1 a MED_MAXCPO cotes
  600. C- Ce segment sert a chaque maillage (a remettre a zero avant lecture du maillage)
  601.       MAITOT = 0
  602.       ntypol = MED_MAXCPO
  603.       ntypel = 1 + MED_GTABLE + ntypol
  604.       SEGINI,MAITOT
  605.  
  606.       LPOLY = 0
  607.       itaill = ntypol
  608.       SEGINI,LPOLY
  609.  
  610.       LISPRO = 0
  611.       SEGINI,LISPRO
  612.  
  613. C***********************************************************************
  614. C* 8 - Boucle sur le ou les maillages et champs a relire
  615. C***********************************************************************
  616.       DO imel = imel_i, imel_f
  617.  
  618.         IF (IMEDMA.EQ.-3) THEN
  619.           name   = LINOMA.CGRNOM(imel)
  620.           ilomai = LONG(name)
  621.           medmai(1:ilomai) = name(1:ilomai)
  622.         ENDIF
  623.  
  624.         NUMLI8 = 0
  625.         SFANOE = 0
  626.         SFAMI  = 0
  627.         SFAMGR = 0
  628.         ICOOR  = 0
  629.         SINT4  = 0
  630.         SLSCHA = 0
  631.         SLSSOR = 0
  632.         SLSFUS = 0
  633.         CHAINF = 0
  634.         CHAPAR = 0
  635.         CHAPRO = 0
  636.         LMAIL2 = 0
  637.         LINDP  = 0
  638.         LCODP  = 0
  639.         LFPOLY = 0
  640.  
  641.         DO ii = 1, ntypel
  642.           maitot.IPOMAI(ii) = 0
  643.           maitot.INUMLI(ii) = 0
  644.         ENDDO
  645.         DO ii = 1, ntypol
  646.           lpoly.INT4(ii) = 0
  647.         ENDDO
  648.         DO ii = 1, ntprof
  649.           lispro.DPNAME(ii) = ' '
  650.           lispro.LNAME(ii)  = ' '
  651.         ENDDO
  652.  
  653. C--- Lecture et traitement du maillage imel
  654.         name = ' '
  655.         it = imel
  656.         CALL MMHMII(mfid, it, name, msdim, mmdim, mmtype, desc, dtunit,
  657.      &              mstype, nstep, matype, ANAME, AUNIT, mcret)
  658.       if (iimpi.EQ.1972) then
  659.         write(ioimp,*) '2) sdim,mtype,mdim,stype,nstep,atype lus :',
  660.      &                 msdim,mmtype,mmdim,mstype,nstep,matype
  661.         write(ioimp,*) (ANAME(i),AUNIT(i),i=1,jdim)
  662.       endif
  663.         IF (mcret .NE. 0) THEN
  664.           moterr    = 'lirmed / mmhmii'
  665.           interr(1) = mcret
  666.           CALL ERREUR(873)
  667.           GOTO 199
  668.         ENDIF
  669.         if (msdim.le.0) then
  670.           moterr    = 'lirmed / mmhmii / msdim'
  671.           interr(1) = msdim
  672.           call erreur(873)
  673.           goto 199
  674.         endif
  675.         ilm = LONG(name)
  676.       if (iimpi.EQ.1972) then
  677.         write(ioimp,*) 'name=',name(1:ilm),'='
  678.       endif
  679.         IF (name(1:ilm) .NE. medmai(1:ilomai)) THEN
  680.           moterr = 'LIRE MED - FATAL ERROR - incorrect MeshName ?'
  681.           CALL ERREUR(5)
  682.           GOTO 199
  683.         ENDIF
  684.         isdim  = msdim
  685.         itypem = mmtype
  686.  
  687. C ***** Lecture du nombre d'entites (Noeuds ici) dans un maillage MED
  688.       if (iimpi.EQ.1972) then
  689.         write(ioimp,*) 'Lecture du nombre d entites (Noeuds ici) '
  690.       endif
  691.         numdt  = MED_NO_DT
  692.         numit  = MED_NO_IT
  693.         metype = MED_NODE
  694.         mgtype = 0
  695.         mdtype = MED_COORDINATE
  696.         mcmode = MED_NODAL
  697.         mchgt  = MED_FALSE
  698.         mtsf   = MED_FALSE
  699.         CALL MMHNME(mfid, name, numdt, numit, metype, mgtype, mdtype,
  700.      &                  mcmode, mchgt, mtsf, n4, mcret)
  701.         IF (mcret .NE. 0) THEN
  702.           moterr = 'lirmed / mmhnme'
  703.           interr(1)  = mcret
  704.           CALL ERREUR(873)
  705.           GOTO 199
  706.         ENDIF
  707.         nbpta = n4
  708.  
  709.       if (iimpi.EQ.1972) then
  710.         write(ioimp,*) 'Lecture des coordonnees des noeuds'
  711.         write(ioimp,*) 'Nombre de noeuds =',nbpta
  712.       endif
  713. C ***** Lecture des coordonnees des noeuds MED
  714.         SEGINI,ICOOR
  715.         numdt = MED_NO_DT
  716.         numit = MED_NO_IT
  717.         mswm  = MED_FULL_INTERLACE
  718.  
  719.         CALL MMHCOR(mfid, name, numdt, numit, mswm, ICOOR.XCOO, mcret)
  720.         IF (mcret .NE. 0) THEN
  721.           moterr    = 'lirmed / mmhcor'
  722.           interr(1) = mcret
  723.           CALL ERREUR(873)
  724.           GOTO 199
  725.         ENDIF
  726. C-----Mise a jour du SEGMENT MCOORD
  727. C-----Les coordonnees des noeuds lus sont placees dans le tableau XCOOR
  728.         NBNOIN = NBPTS
  729.         ndec   = mcoord.XCOOR(/1)
  730.         NBPTS  = NBNOIN + nbpta
  731.         SEGADJ,MCOORD
  732.         DO ia = 1, nbpta
  733.           DO ii = 1, isdim
  734.             mcoord.XCOOR(ndec+ii) = ICOOR.XCOO(ii,ia)
  735.           ENDDO
  736.           ndec = ndec + IDIMP1
  737.         ENDDO
  738.       if (iimpi.EQ.1972) then
  739.         write(ioimp,*) '- Coordonnees des noeuds :',nbpta,NBNOIN
  740.         do ia = 1, min(nbpta,200)
  741.           write(ioimp,*) '[',ia,']',(xcoo(i,ia),i=1,isdim)
  742.         enddo
  743.         if (nbpta.gt.200) write(ioimp,*) '[ ... ]'
  744.       endif
  745.  
  746. C-----Creation du MAILLAGE SIMPLE de POI1
  747. C-----La connectivite lue est decalee si des noeuds existaient avant (NBNOIN)
  748.         nbnn   = 1
  749.         nbelem = nbpta
  750.         nbsous = 0
  751.         nbref  = 0
  752.         SEGINI,IPT1
  753.         IPT1.ITYPEL = 1
  754.         DO ib = 1, nbelem
  755.           IPT1.NUM(1,ib)  = NBNOIN + ib
  756.           IPT1.ICOLOR(ib) = idcoul
  757.         ENDDO
  758.       if (iimpi.EQ.1972) then
  759.         write(ioimp,*) 'Creation du MAILLAGE SIMPLE de POI1',IPT1
  760.       endif
  761. C On preconditionne le maillage POI1 des noeuds avant toute utilisation
  762.         CALL CRECH1(IPT1,1)
  763.  
  764. C ***** Lecture des numeros de famille des noeuds pour generer les POI1
  765.         if (iimpi.EQ.1972) then
  766.           write(ioimp,*) 'Lecture des numeros de famille des noeuds'
  767.         endif
  768.         nbelem = nbpta
  769.         SEGINI,NUMLI8
  770.  
  771.         numdt  = MED_NO_DT
  772.         numit  = MED_NO_IT
  773.         metype = MED_NODE
  774.         mgtype = 0
  775.         CALL MMHFNR(mfid, name, numdt, numit, metype, mgtype,
  776.      &              NUMLI8.NUMLIS, mcret)
  777.         IF (mcret.GT.0) THEN
  778.           moterr    = 'lirmed / mmhfnr'
  779.           interr(1) = mcret
  780.           CALL ERREUR(873)
  781.           GOTO 199
  782.         ENDIF
  783.       if (iimpi.EQ.1972) then
  784.         write(ioimp,*) 'NUMLI8',numli8,nbelem,nbpta
  785. c#DBG       write(ioimp,'(2000000(1X,I2,1X))') (numli8.numlis(i),i=1,nbelem)
  786.       endif
  787.  
  788.         nbtype = 1
  789. C-----Sauvegarde du pointeur vers le MELEME simple
  790.         maitot.IPOMAI(nbtype) = IPT1
  791. C-----Sauvegarde du pointeur vers le tableau des numeros de famille de chaque noeud de ce MAILLAGE SIMPLE de POI1
  792.         maitot.INUMLI(nbtype) = NUMLI8
  793. C Verifier que l'on se sert de ce maillage de POI1 comme reference pour les CHPOINTS
  794.  
  795. C-----Boucle sur tous les types d'elements autres que POI1 (deja traite)
  796. C ***** Lecture du nombre d'entites (Elements ici) en balayant tous les
  797. C ***** MAILLAGES SIMPLES d'un maillage MED >= 3.*
  798. C ***** TRAITEMENT PARTICULIER des elements MED_POLYGON soit ity=32 'POLY'
  799.         DO itypem = 1, MED_GTABLE
  800.  
  801.           numdt  = MED_NO_DT
  802.           numit  = MED_NO_IT
  803.           metype = MED_CELL
  804.           mgtype = MEDGTB(itypem)
  805.  
  806.           ITY     = MDICLA(mgtype)
  807.           IF (ITY .EQ. 32) GOTO 211
  808.  
  809. C ***** Cas general *****
  810.       if (iimpi.eq.1972) then
  811.         write(ioimp,*) 'Lecture maillage elementaire - cas general'
  812.         write(ioimp,*) 'Type',itypem,mgtype,ITY,NOMS(ITY)
  813.       endif
  814. C--- Lecture du nombre d'elements :
  815.           mdtype = MED_CONNECTIVITY
  816.           mcmode = MED_NODAL
  817.           mchgt  = MED_FALSE
  818.           mtsf   = MED_FALSE
  819.           CALL MMHNME(mfid  ,   name, numdt, numit, metype, mgtype,
  820.      &                mdtype, mcmode, mchgt, mtsf , n4    , mcret)
  821.           IF (mcret .NE. 0) THEN
  822.             moterr    = 'lirmed / mmhnme'
  823.             interr(1) = mcret
  824.             CALL ERREUR(873)
  825.             GOTO 199
  826.           ENDIF
  827.           nbelem = n4
  828.           IF (nbelem .EQ. 0) GOTO 21
  829. C--- Lecture de la connectivite des elements
  830.           nbnn   = NBNNE(ITY)
  831.           nbsous = 0
  832.           nbref  = 0
  833.           SEGINI,IPT1
  834.           IPT1.ITYPEL = ITY
  835.           DO ib = 1, nbelem
  836.             IPT1.ICOLOR(ib) = idcoul
  837.           ENDDO
  838.           if (iimpi.eq.1972) then
  839.             write(ioimp,*) 'Maillage ',nbelem,nbnn,IPT1
  840.           endif
  841.           mcmode = MED_NODAL
  842.           mswm   = MED_FULL_INTERLACE
  843.           CALL MMHCYR(mfid, name, numdt, numit, metype, mgtype,
  844.      &                mcmode, mswm, IPT1.NUM, mcret)
  845.           IF (mcret .NE. 0) THEN
  846.             moterr    = 'lirmed / mmhcyr'
  847.             interr(1) = mcret
  848.             CALL ERREUR(873)
  849.             GOTO 199
  850.           ENDIF
  851.           if (iimpi.eq.1972) then
  852.             write(ioimp,*) 'Lect. des familles des elements'
  853.           endif
  854.           SEGINI,NUMLI8
  855.           CALL MMHFNR(mfid, name, numdt, numit, metype, mgtype,
  856.      &                NUMLI8.NUMLIS, mcret)
  857.           IF (mcret .NE. 0) THEN
  858.             moterr    = 'lirmed / mmhfnr'
  859.             interr(1) = mcret
  860.             CALL ERREUR(873)
  861.             GOTO 199
  862.           ENDIF
  863.  
  864.           nmai2 = 1
  865.           itaill = 2 * nmai2
  866.           SEGINI,LMAIL2
  867.           LMAIL2.INT4(1) = IPT1
  868.           LMAIL2.INT4(2) = NUMLI8
  869.           GOTO 210
  870.  
  871. C **** Cas particulier des MED_POLYGON & ity=32 ****
  872.  211      CONTINUE
  873.       if (iimpi.eq.1972) then
  874.         write(ioimp,*) 'Lecture maillage elementaire - cas POLYGON'
  875.         write(ioimp,*) 'Type',itypem,mgtype,ITY,NOMS(ITY)
  876.       endif
  877.  
  878.           mdtype = MED_INDEX_NODE
  879.           mcmode = MED_NODAL
  880.           mchgt  = MED_FALSE
  881.           mtsf   = MED_FALSE
  882.           CALL MMHNME(  mfid,   name, numdt , numit,
  883.      &                metype, mgtype, mdtype,
  884.      &                mcmode,  mchgt,  mtsf , n4, mcret)
  885.           IF (mcret .NE. 0) THEN
  886.             moterr    = 'lirmed / mmhnme'
  887.             interr(1) = mcret
  888.             CALL ERREUR(873)
  889.             GOTO 199
  890.           ENDIF
  891.           nbpoly = n4 - 1
  892.           IF (nbpoly .LE. 0) GOTO 21
  893. C--- Lecture de la connectivite des elements
  894.           mdtype = MED_CONNECTIVITY
  895.           mcmode = MED_NODAL
  896.           mchgt  = MED_FALSE
  897.           mtsf   = MED_FALSE
  898.           CALL MMHNME(  mfid,   name,  numdt,  numit,
  899.      &                metype, mgtype, mdtype,
  900.      &                mcmode,  mchgt,  mtsf ,  n4, mcret)
  901.           IF (mcret .NE. 0) THEN
  902.             moterr    = 'lirmed / mmhnme'
  903.             interr(1) = mcret
  904.             CALL ERREUR(873)
  905.             GOTO 199
  906.           ENDIF
  907.           nbconn = n4
  908.  
  909.       if (iimpi.eq.1972) then
  910.         write(ioimp,*) 'Maillage ',nbpoly,nbconn
  911.       endif
  912.  
  913.           itaill = nbpoly + 1
  914.           SEGINI,LINDP
  915.           itaill = nbconn
  916.           SEGINI,LCONP
  917.           CALL MMHPGR(mfid  , name, numdt, numit, metype, mcmode,
  918.      &                LINDP.INT4,LCONP.INT4, mcret)
  919.           IF (mcret .NE. 0) THEN
  920.             moterr    = 'lirmed / mmhpgr'
  921.             interr(1) = mcret
  922.             CALL ERREUR(873)
  923.             GOTO 199
  924.           ENDIF
  925.           if (iimpi.eq.1972) then
  926.             write(ioimp,*) 'Lect. des familles des elements'
  927.           endif
  928.           nbelem = nbpoly
  929.           SEGINI,LFPOLY
  930.           CALL MMHFNR(mfid, name, numdt, numit, metype, mgtype,
  931.      &                LFPOLY.NUMLIS, mcret)
  932.           IF (mcret .NE. 0) THEN
  933.             moterr    = 'lirmed / mmhfnr'
  934.             interr(1) = mcret
  935.             CALL ERREUR(873)
  936.             GOTO 199
  937.           ENDIF
  938.  
  939.           DO ib = 1, nbpoly
  940.             ind1 = LINDP.INT4(ib)
  941.             ind2 = LINDP.INT4(ib+1)-1
  942.             nbnn = ind2 - ind1 + 1
  943.             lpoly.INT4(nbnn) = lpoly.INT4(nbnn) + 1
  944.           END DO
  945.           i_z = 0
  946.           nmai2 = 0
  947.           DO ib = 1, ntypol
  948.             nbelem = lpoly.INT4(ib)
  949.             i_z = i_z + nbelem
  950.             IF (nbelem.NE.0) nmai2 = nmai2 + 1
  951.           ENDDO
  952.           IF (i_z.NE.nbpoly) then
  953.             moterr    = 'lirmed / verif nbpoly'
  954.             interr(1) = 1
  955.             CALL ERREUR(873)
  956.             GOTO 199
  957.           ENDIF
  958.           itaill = 2 * nmai2
  959.           SEGINI,LMAIL2
  960.           nbsous = 0
  961.           nbref  = 0
  962.           nmai2  = 0
  963.           DO ib = 1, ntypol
  964.             nbnn   = ib
  965.             nbelem = lpoly.INT4(ib)
  966.             IF (nbelem.NE.0) THEN
  967.               SEGINI,IPT1
  968.               IPT1.ITYPEL = ITY
  969.               DO ia = 1, nbelem
  970.                 IPT1.ICOLOR(ia) = idcoul
  971.               ENDDO
  972.               IPT1.ICOLOR(1) = 0
  973.               SEGINI,NUMLI8
  974.               nmai2 = nmai2 + 1
  975.               LMAIL2.INT4(2*nmai2-1) = IPT1
  976.               LMAIL2.INT4(2*nmai2)   = NUMLI8
  977.               lpoly.INT4(ib) = nmai2
  978.             ENDIF
  979.           ENDDO
  980.           DO ib = 1, nbpoly
  981.             ind1 = LINDP.INT4(ib)
  982.             ind2 = LINDP.INT4(ib+1)-1
  983.             nbnn = ind2 - ind1 + 1
  984.             ii = lpoly.INT4(nbnn)
  985.             IPT1   = LMAIL2.INT4(2*ii-1)
  986.             NUMLI8 = LMAIL2.INT4(2*ii)
  987.             ielt = IPT1.ICOLOR(1) + 1
  988.             DO ia = 1, nbnn
  989.               IPT1.NUM(ia,ielt) = LCONP.INT4(ind1-1+ia)
  990.             ENDDO
  991.             IPT1.ICOLOR(1) = ielt
  992.             NUMLI8.NUMLIS(ielt) = LFPOLY.NUMLIS(ib)
  993.           ENDDO
  994.           SEGSUP,LINDP,LCONP
  995.           itaill = nbconn
  996.           GOTO 210
  997.  
  998.  210    CONTINUE
  999.           itaill = 50
  1000.           SEGINI,SINT4
  1001.  
  1002.           DO ii = 1, nmai2
  1003.             IPT1   = LMAIL2.INT4(2*ii-1)
  1004.             NUMLI8 = LMAIL2.INT4(2*ii)
  1005.  
  1006.             nbnn   = IPT1.NUM(/1)
  1007.             nbelem = IPT1.NUM(/2)
  1008.             IPT1.ICOLOR(1) = idcoul
  1009.  
  1010. C---------La connectivite lue est decalee si des noeuds existaient avant
  1011.             IF (NBNOIN .NE. 0) THEN
  1012.               DO ib = 1, nbelem
  1013.                 DO ia = 1, nbnn
  1014.                   IPT1.NUM(ia,ib) = IPT1.NUM(ia,ib) + NBNOIN
  1015.                 ENDDO
  1016.               ENDDO
  1017.             ENDIF
  1018.  
  1019. C---------Passage de la connectivite MED a Cast3M si besoin
  1020.             IPER = MEDPER(ITY)
  1021.             IF (IPER .GE. 0) THEN
  1022.               if (nbnn.gt.itaill) call erreur(5)
  1023.               nn = nbnn - 1
  1024.               DO ib = 1, nbelem
  1025.                 DO ia = 1, nn
  1026.                   SINT4.INT4(ia) = ipt1.num(ia+1,ib)
  1027.                 ENDDO
  1028.                 DO ia = 1, nn
  1029.                   ipt1.num(IPERM(IPER+ia),ib) = SINT4.INT4(ia)
  1030.                 ENDDO
  1031.               ENDDO
  1032.             ENDIF
  1033.  
  1034.             nbtype = nbtype + 1
  1035. C---------Sauvegarde du pointeur vers le MELEME simple
  1036.             maitot.IPOMAI(nbtype) = IPT1
  1037. C---------Sauvegarde du pointeur vers le tableau des numeros de famille de chaque element de ce MAILLAGE SIMPLE
  1038.             maitot.INUMLI(nbtype) = NUMLI8
  1039.  
  1040.           ENDDO
  1041.           SEGSUP,SINT4
  1042.  
  1043.           SEGSUP,LMAIL2
  1044.  
  1045.  21     CONTINUE
  1046.         ENDDO
  1047.  
  1048. C-- Le SEGMENT MAITOT est de dimension ntypel, mais seuls les nbtype 
  1049. C-- premiers indices sont utilises
  1050.  
  1051. C ***** Creation du MAILLAGE complet des FAMILLES => Partition
  1052. C ***** Creation d'un MAILLAGE COMPLEXE contenant tous les MELEME SIMPLES
  1053.         nbsous = nbtype - 1
  1054.         IF      (nbsous.EQ.0) THEN
  1055.           moterr = 'LIRE MED - Only points read !'
  1056.           call erreur(-385)
  1057.           nbref  = 0
  1058.           nbelem = 0
  1059.           nbnn   = 0
  1060.           SEGINI,IPT1
  1061.           IPT1.ITYPEL = 0
  1062.           SEGDES,IPT1
  1063.         ELSE IF (nbsous.EQ.1) THEN
  1064.           IPT1 = maitot.IPOMAI(nbsous+1)
  1065.         ELSE 
  1066.           nbref  = 0
  1067.           nbelem = 0
  1068.           nbnn   = 0
  1069.           SEGINI,IPT1
  1070.           DO ia = 1,nbsous
  1071.             IPT1.lisous(ia) = maitot.IPOMAI(ia+1)
  1072.           ENDDO
  1073.           SEGDES,IPT1
  1074.         ENDIF
  1075. C-----Ecriture dans la table du MAILLAGE complet des FAMILLES
  1076.       if (iimpi.eq.1972) then
  1077.         write(ioimp,*) 'Ecriture dans la table du maillage ',IPT1
  1078.       endif
  1079.         typobj = 'MAILLAGE'
  1080.         CALL ECCTAB(MTABLE,typmot,inin,floin,MEDMAI(1:ilomai),
  1081.      &                              login,inin,
  1082.      &                     typobj,inre,flore,charre          ,
  1083.      &                              logre,IPT1)
  1084.         IPT1 = maitot.IPOMAI(1)
  1085.         CALL ECCTAB(MTABLE,typmot,inin,floin,MEDMAI(1:ilomai)//'_POI1',
  1086.      &                              login,inin,
  1087.      &                     typobj,inre,flore,charre                   ,
  1088.      &                              logre,IPT1)
  1089.         IF (IERR.NE.0) GOTO 199
  1090.  
  1091. C ***** Lecture du nombre de familles du maillage
  1092.         CALL MFANFA(mfid, name, n4, mcret)
  1093.         IF (mcret .NE. 0) THEN
  1094.           moterr    = 'lirmed / mfanfa'
  1095.           interr(1) = mcret
  1096.           CALL ERREUR(873)
  1097.           GOTO 199
  1098.         ENDIF
  1099.         infam = n4
  1100.       if (iimpi.eq.1972) then
  1101.         write(ioimp,*) 'Nombre de familles du maillage',infam
  1102.       endif
  1103.  
  1104.         ncompg = 0
  1105.         ngrdif = 10
  1106.         SEGINI,SGRTOT
  1107.  
  1108.         SEGINI,SFAMI
  1109.         DO ifam = 1, infam
  1110.           if (iimpi.eq.1972) then
  1111.             write(ioimp,*) 'Famille ' ,ifam, ' / ' , infam
  1112.           endif
  1113. C ***** Lecture du nombre de groupes dans une famille
  1114.           it1 = ifam
  1115.           CALL MFANFG(mfid, name, it1, n4, mcret)
  1116.           IF (mcret .NE. 0) THEN
  1117.             moterr    = 'lirmed / mfanfg'
  1118.             interr(1) = mcret
  1119.             CALL ERREUR(873)
  1120.             GOTO 199
  1121.           ENDIF
  1122.           ngroup = n4
  1123.       if (iimpi.eq.1972) then
  1124.         write(ioimp,*) 'Lecture nombre groupes famille ',name,ngroup
  1125.       endif
  1126.           SEGINI,SFAMGR
  1127.  
  1128. C ***** Lecture des informations sur une famille
  1129.           it1 = ifam
  1130.           CALL MFAFAI(mfid, name, it1, fam, mfnum, SFAMGR.CFGRN, mcret)
  1131.           if (iimpi.eq.1972) then
  1132.             write(ioimp,*)
  1133.             write(ioimp,*) 'Lecture des informations sur une famille ',ifam
  1134.             write(ioimp,*) 'fam =',fam
  1135.             write(ioimp,*) 'fnum=',mfnum
  1136.             write(ioimp,*) 'sfamgr-',(SFAMGR.CFGRN(ii),'-',ii=1, ngroup)
  1137.           endif
  1138.           IF (mcret .NE. 0) THEN
  1139.             moterr    = 'lirmed / mfafai'
  1140.             interr(1) = mcret
  1141. C          CALL ERREUR(873)
  1142. C          GOTO 199
  1143.           ENDIF
  1144.  
  1145.           SFAMI.IFAMNU(ifam) = mfnum
  1146.           SFAMI.PFAMGR(ifam) = SFAMGR
  1147.           SFAMI.CFANOM(ifam) = fam
  1148.  
  1149. C-------Construction a la volee de la liste des groupes differents
  1150.           IF (ngroup .GT. 0) THEN
  1151. C---------Cas ou le nombre de groupe(s) n'est pas nul
  1152.             IF (ncompg .EQ. 0) THEN
  1153. C-----------Cas ou la liste est vierge ==> Ajout de tous les noms
  1154.               ncompg = ncompg + ngroup
  1155. C-----------Ajustement intermediaire (eventuel) du SEGMENT SGRTOT
  1156.               IF (ncompg.GT.ngrdif) THEN
  1157.                 ngrdif = ncompg * 2 + 10
  1158.                 SEGADJ,SGRTOT
  1159.               ENDIF
  1160.               DO ii = 1, ngroup
  1161.                 SGRTOT.CGRNOM(ii) = SFAMGR.CFGRN(ii)
  1162.               ENDDO
  1163.             ELSE
  1164. C-----------Cas ou des noms de groupes existent deja ==> Comparaison aux noms existants
  1165.               DO igroup = 1, ngroup
  1166.                 iverif = 0
  1167.                 DO ii = 1, ncompg
  1168.                   IF (SFAMGR.CFGRN(igroup).EQ.SGRTOT.CGRNOM(ii)) THEN
  1169.                     iverif = 1
  1170.                   ENDIF
  1171.                 ENDDO
  1172.  
  1173.                 IF (iverif .EQ. 0) THEN
  1174. C---------------Ajout du groupe s'il n'existe pas deja
  1175.                   ncompg = ncompg + 1
  1176.  
  1177. C---------------Ajustement intermediaire (eventuel) du SEGMENT SGRTOT
  1178.                   IF (ncompg .GT. ngrdif) THEN
  1179.                     ngrdif = ngrdif * 2
  1180.                     SEGADJ SGRTOT
  1181.                   ENDIF
  1182.                   SGRTOT.CGRNOM(ncompg) = SFAMGR.CFGRN(igroup)
  1183.                 ENDIF
  1184.               ENDDO
  1185.             ENDIF
  1186.           ENDIF
  1187.  
  1188.         ENDDO
  1189.  
  1190. C-----Ajustement final (eventuel) du SEGMENT SGRTOT
  1191.         IF (ncompg .NE. ngrdif) THEN
  1192.           ngrdif = ncompg
  1193.           SEGADJ,SGRTOT
  1194.         ENDIF
  1195.       if (iimpi.eq.1972) then
  1196.         write(ioimp,*) 
  1197.         write(ioimp,*)  'SGRTOT',ngrdif
  1198.         do i = 1, ngrdif
  1199.           write(ioimp,*) i, SGRTOT.CGRNOM(i)
  1200.         enddo
  1201.       endif
  1202.  
  1203. C ***** Reconstitution des dependances des maillages dans Cast3M
  1204. C-----creation des maillages des familles (POI1 compris)
  1205.         nbref  = 0
  1206.         nbsous = 0
  1207.         IPT3   = 0
  1208.  
  1209. C-----Boucle sur les familles lues
  1210.         DO ifam = 1, infam
  1211.           inufam = SFAMI.IFAMNU(ifam)
  1212.           IPT3   = 0
  1213.           if (iimpi.eq.1972) then
  1214.             write(ioimp,*)
  1215.             write(ioimp,*) 'ifam=',ifam,inufam
  1216.           endif
  1217. C-------Boucle sur les types d'elements
  1218.           DO itype = 1, nbtype
  1219. C---------Chargement du numero de famille de la ifam ieme famille
  1220.             NUMLI8 = maitot.INUMLI(itype)
  1221.             nbelem = 0
  1222.             ielfam = 0
  1223.             DO ielem = 1, NUMLI8.NUMLIS(/1)
  1224. C-----------Calcule le nombre d'elements du type itype appartenant a la famille ifam
  1225.               IF (NUMLI8.NUMLIS(ielem) .EQ. inufam) THEN
  1226.                 nbelem = nbelem+1
  1227.                 ielfam = ielem
  1228.               ENDIF
  1229.             ENDDO
  1230.  
  1231.             IF (nbelem .GT. 0) THEN
  1232. C-----------Cas ou un maillage d'elements de type itype est a creer pour la famille ifam
  1233. C-----------Chargement du maillage complet du type d'element itype
  1234.               IPT1 = maitot.IPOMAI(itype)
  1235.               nbnn = IPT1.num(/1)
  1236.  
  1237. C* cas particulier des POINTS NOMMES : Solution temporaire
  1238.               IF (nbnn .EQ.1 .AND. nbelem.EQ.1) THEN
  1239.                 IPT3 = -IPT1.num(1,ielfam)
  1240.                 GOTO 762
  1241.               ENDIF
  1242.  
  1243. C-----------Creation du nouveau maillage compose de la partition des elements de IPT1 appartenant a la famille ifam
  1244.               SEGINI IPT2
  1245.               iel = 0
  1246.               IPT2.itypel = IPT1.itypel
  1247.               DO ielem = 1, NUMLI8.NUMLIS(/1)
  1248.                 IF (NUMLI8.NUMLIS(ielem) .EQ. inufam) THEN
  1249.                   iel = iel+1
  1250.                   DO ia = 1, nbnn
  1251.                     IPT2.num(ia,iel) = IPT1.num(ia,ielem)
  1252.                   ENDDO
  1253.                   IPT2.icolor(iel) = idcoul
  1254.                 ENDIF
  1255.               ENDDO
  1256.  
  1257. C-----------Creation du MELEME COMPLEXE s'il y a lieu
  1258.               IF (IPT3 .EQ. 0) THEN
  1259.                 IPT3=IPT2
  1260.               ELSE
  1261. C-------------Fusion des maillages IPT3 et IPT2 dans IPT4
  1262.                 CALL FUSE(IPT3, IPT2, IPT4, ltelq)
  1263.                 IPT3 = IPT4
  1264.               ENDIF
  1265.  762        CONTINUE
  1266.             ENDIF
  1267.           ENDDO
  1268.           SFAMI.PFAMAI(ifam) = IPT3
  1269.         ENDDO
  1270.  
  1271. C-----creation des maillages des groupes : OBJETS NOMMES DANS CAST3M
  1272.         DO igroup=1,ngrdif
  1273.           char80 = SGRTOT.CGRNOM(igroup)
  1274.       if (iimpi.eq.1972) then
  1275.         write(ioimp,*) ' igr',igroup,char80(1:long(char80))
  1276.       endif
  1277.           IPT3   =  0
  1278.           DO ifam = 1, infam
  1279.             SFAMGR = SFAMI.PFAMGR(ifam)
  1280.             DO inomgr = 1, SFAMGR.CFGRN(/2)
  1281.               IF (char80 .EQ. SFAMGR.CFGRN(inomgr)) THEN
  1282.                 IPT2 = SFAMI.PFAMAI(ifam)
  1283.       if (iimpi.eq.1972) then
  1284.         write(ioimp,*) ' igr',igroup,inomgr,IPT2
  1285.       endif
  1286.                 IF (IPT3 .EQ. 0)THEN
  1287.                   IPT3 = IPT2
  1288.                 ELSE
  1289. C---------------Fusion des maillages IPT3 et IPT2 dans IPT4
  1290.                   IF (IPT3.LT.0) THEN
  1291.                     IPT3 = -IPT3
  1292.                     CALL CRELEM(IPT3)
  1293.                   ENDIF
  1294.                   IF (IPT2.LT.0) THEN
  1295.                     IPT2 = -IPT2
  1296.                     CALL CRELEM(IPT2)
  1297.                   ENDIF
  1298.                   CALL FUSE(IPT3, IPT2, IPT4, ltelq)
  1299.                   IPT3 = IPT4
  1300.                 ENDIF
  1301.                 GOTO 115
  1302.               ENDIF
  1303.             ENDDO
  1304.  115        CONTINUE
  1305.           ENDDO
  1306.  
  1307. C       En cas de MAILLAGE VIDE dans MED :(Ne s'appuyant sur aucune FAMILLE) : C'est possible !
  1308.           IF (IPT3 .EQ. 0) THEN
  1309.             ITEL   = ILCOUR
  1310.             NBELEM = 0
  1311.             NBSOUS = 0
  1312.             NBREF  = 0
  1313.             IF (NOMS(ITEL).EQ.'POLY') THEN
  1314.               NBNN = 0
  1315.             ELSEIF (NOMS(ITEL).EQ.'MULT') THEN
  1316.               NBNN = 0
  1317.             ELSE
  1318.               NBNN = NBNNE(ITEL)
  1319.             ENDIF
  1320.             SEGINI,IPT3
  1321.             IPT3.ITYPEL=ITEL
  1322.           ENDIF
  1323.  
  1324. C-----Ecriture dans la table du MAILLAGE du Groupe
  1325.           IF (char80 .NE. ' ') THEN
  1326.             IF (IPT3.GT.0) THEN
  1327.               typobj = 'MAILLAGE'
  1328.               CALL ECCTAB(MTABLE,typmot,inin,floin,char80,login,inin,
  1329.      &                           typobj,inre,flore,charre,logre,IPT3)
  1330.             ELSE
  1331.               typobj = 'POINT   '
  1332.               CALL ECCTAB(MTABLE,typmot,inin,floin,char80,login,inin,
  1333.      &                           typobj,inre,flore,charre,logre,-IPT3)
  1334.             ENDIF
  1335.           ENDIF
  1336.         ENDDO
  1337.  
  1338. C***********************************************************************
  1339. C      Lecture des champs
  1340. C***********************************************************************
  1341.         IF (nbcham .EQ. 0) GOTO 100
  1342.         ncham = nbcham
  1343.         SEGINI,SLSCHA
  1344.         SLSCHA.LSNMAI = name
  1345.  
  1346.         icham = 0
  1347.         DO ia = 1, nbcham
  1348.  
  1349.       if (iimpi.eq.1972) then
  1350.         write(ioimp,*) 'Champ ',ia,' / ',nbcham
  1351.       endif
  1352.           it = ia
  1353. C-------Nombre de composantes d'un champ
  1354.           CALL mfdnfc(mfid, it, n4, mcret)
  1355.           IF (mcret .NE. 0) THEN
  1356.             moterr    = 'lirmed / mfdnfc'
  1357.             interr(1) = mcret
  1358.             CALL ERREUR(873)
  1359.             GOTO 199
  1360.           ENDIF
  1361.           ncomp = n4
  1362.           nseq = 1
  1363.           SEGINI,CHAINF
  1364. C-------Information sur le champ
  1365.           fname = ' ' 
  1366.           mname = ' '
  1367.           CALL mfdfdi(mfid, it, fname, mname, lmesh, mmtype,
  1368.      &                CHAINF.CNAME,CHAINF.CUNIT, dtunit, n4, mcret)
  1369.           IF (mcret .NE. 0) THEN
  1370.             moterr    = 'lirmed / mfdfdi'
  1371.             interr(1) = mcret
  1372.             CALL ERREUR(873)
  1373.             GOTO 199
  1374.           ENDIF
  1375.       if (iimpi.eq.1972) then
  1376.         write(ioimp,*) ' mname,fname=',mname(1:long(mname)),'=',
  1377.      &                 fname(1:long(fname)),'='
  1378.       endif
  1379.           IF (mname.NE.name) THEN
  1380.       if (iimpi.eq.1972) then
  1381.         moterr = 'LIRE MED - mname & name are different ?'
  1382.         CALL ERREUR(-385)
  1383.         moterr = mname(1:long(mname))//' & '//name(1:ilomai)
  1384.         CALL ERREUR(-385)
  1385.       endif
  1386.             goto 25
  1387.           END IF
  1388.           nseq = n4
  1389.           IF (nseq .EQ. 0) THEN
  1390.             moterr = ' LIRE MED - ERREUR nseq=0'
  1391.             CALL ERREUR(-385)
  1392.             CALL ERREUR(21)
  1393.             GOTO 199
  1394.           ENDIF
  1395.           IF (nseq .GT. 1) THEN
  1396.             SEGADJ,CHAINF
  1397.           ENDIF
  1398.       if (iimpi.eq.1972) then
  1399.         write(ioimp,*) 'Composantes du champ ',ncomp
  1400.         write(ioimp,*) '-',(CNAME(ii)//'-',ii=1,ncomp)
  1401.       endif
  1402. C       Certains fichiers MED ont des CHAMPS sans composantes nommees !
  1403.           DO ii = 1, ncomp
  1404.             IF (CHAINF.CNAME(ii) .EQ. '                ') THEN
  1405.               CHAINF.CNAME(ii) = 'SCAL'
  1406.             ENDIF
  1407.           ENDDO
  1408.  
  1409.       if (iimpi.eq.1972) then
  1410.         write(ioimp,*) 'Nombre de sequences du champ',nseq
  1411.       endif
  1412.           DO ii = 1, nseq
  1413. C---------Lecture des informations caracterisant une sequence de calcul
  1414.             it1 = ii
  1415.             CALL mfdcsi(mfid, fname, it1, numdt, numit, dt, mcret)
  1416.             IF (mcret .NE. 0) THEN
  1417.               moterr    = 'lirmed / mfdcsi'
  1418.               interr(1) = mcret
  1419.               CALL ERREUR(873)
  1420.               GOTO 199
  1421.             ENDIF
  1422.             CHAINF.INUMDT(ii) = numdt
  1423.             CHAINF.INUMIT(ii) = numit
  1424.             CHAINF.XDT(ii)    = dt
  1425.           ENDDO
  1426.  
  1427.           icham = icham + 1
  1428.           SLSCHA.LSNCHA(icham) = fname
  1429.           SLSCHA.LSCHIN(icham) = CHAINF
  1430.           SLSCHA.LSPARA(icham) = 0
  1431.       if (iimpi.eq.1972) then
  1432.         write(ioimp,*) 'Ecriture de ',mname,fname,'-> LSNMAI',icham
  1433.       endif
  1434.  25       CONTINUE
  1435.         ENDDO
  1436.         IF (icham.NE.ncham) THEN
  1437.           ncham = icham
  1438.           SEGADJ,SLSCHA
  1439.         END IF
  1440.       if (iimpi.eq.1972) then
  1441.         write(ioimp,*) 'Nombre de champs lus pour ce maillage',ncham
  1442.       endif
  1443.  
  1444. C ***** Recherche des parametres numeriques
  1445.         DO iparam = 1, nparam
  1446.  
  1447.           it1 = iparam
  1448.           CALL mprpri(mfid, it1, dname, mmtype, desc, dtunit,
  1449.      &                nstep, mcret)
  1450.       if (iimpi.eq.1972) then
  1451.         write(ioimp,*) 'param',iparam,'-',dname,'-'
  1452.       endif
  1453.           IF (mcret .NE. 0) THEN
  1454.             moterr    = 'lirmed / mprpri'
  1455.             interr(1) = mcret
  1456.             CALL ERREUR(873)
  1457.             GOTO 199
  1458.           ENDIF
  1459.  
  1460. C-------On regarde si cela correspond a un champ existant
  1461.           CALL MEDNML(-1, 1, dname, cha64a, isca)
  1462.           CALL MEDNML(-2, 1, dname, cha64b, iscb)
  1463.           IF (isca .GT. 0 .AND. iscb .GT. 0) THEN
  1464.             CALL PLACE(SLSCHA.LSNCHA, ncham, iamo, cha64b)
  1465.  
  1466.             IF (iamo .GT. 0) THEN
  1467.               numdt = MED_NO_DT
  1468.               numit = MED_NO_IT
  1469.               CALL mprivr(mfid, dname, numdt, numit, mdval, mcret)
  1470.               IF (mcret .NE. 0) THEN
  1471.                 moterr    = 'lirmed / mprivr'
  1472.                 interr(1) = mcret
  1473.                 CALL ERREUR(873)
  1474.                 GOTO 199
  1475.               ENDIF
  1476.               CHAPAR = SLSCHA.LSPARA(iamo)
  1477.               IF (CHAPAR .EQ. 0) THEN
  1478.                 ncpars = 1
  1479.                 SEGINI CHAPAR
  1480.               ELSE
  1481.                 ncpars = CHAPAR.CPARVL(/1) + 1
  1482.                 SEGADJ CHAPAR
  1483.               ENDIF
  1484.               CHAPAR.CPARNM(ncpars) = cha64a(1:isca)
  1485.               CHAPAR.CPARVL(ncpars) = mdval
  1486.               SLSCHA.LSPARA(iamo)   = CHAPAR
  1487.             ENDIF
  1488.           ENDIF
  1489.         ENDDO
  1490.  
  1491. C ***** Recherche des profils et mise en place des champs a sortir
  1492. C-----Initialisation
  1493.         nbsor = 0
  1494.         nbso  = 0
  1495.         SEGINI,SLSSOR
  1496.  
  1497. C-----Boucle sur tous les pas de tps de chaque champ. On suppose qu'un
  1498. C-----champ peut etre defini soit sur un profil soit sur le maillage total
  1499.         DO ia = 1, ncham
  1500.           fname  = SLSCHA.LSNCHA(ia)
  1501.           CHAINF = SLSCHA.LSCHIN(ia)
  1502.           ndt    = CHAINF.INUMDT(/1)
  1503.           typobj = '        '
  1504.  
  1505.           DO idt = 1, ndt
  1506.             numdt = CHAINF.INUMDT(idt)
  1507.             numit = CHAINF.INUMIT(idt)
  1508.             ip    = 0
  1509.             nprof = ntprof*MED_GTABLE*MED_ETABLE
  1510.             SEGINI CHAPRO
  1511.  
  1512. C---------Avec profil
  1513. C---------CHPOINT
  1514.             metype = MED_NODE
  1515.             mgtype = MED_NONE
  1516.  
  1517.             CALL mfdnpf(mfid, fname, numdt, numit, metype, mgtype,
  1518.      &                  lispro.DPNAME, lispro.LNAME, n4, mcret)
  1519.             IF (mcret .NE. 0) THEN
  1520.               moterr    = 'lirmed / mfdnpf'
  1521.               interr(1) = mcret
  1522.               CALL ERREUR(873)
  1523.               GOTO 199
  1524.             ENDIF
  1525.             nprof = n4
  1526.             IF (nprof .GT. 0) THEN
  1527.               IF (typobj .EQ. '        ') typobj = 'CHPOINT '
  1528.               IF (typobj .NE. 'CHPOINT ') THEN
  1529.                 moterr = ' ERREUR On voulait CHPOINT mais on a '//typobj
  1530.                 CALL ERREUR(-385)
  1531.                 CALL ERREUR(21)
  1532.                 GOTO 199
  1533.               ENDIF
  1534.       if (iimpi.eq.1972) then
  1535.         write(ioimp,*) ' On a CHPOINT profil',nprof,idt,ip
  1536.       endif
  1537.               DO ib = 1, nprof
  1538.                 ip = ip + 1
  1539.                 CHAPRO.CTYPE(ip)  = typobj
  1540.                 CHAPRO.CPRONA(ip) = lispro.DPNAME(ib)
  1541.                 CHAPRO.CETYPE(ip) = metype
  1542.                 CHAPRO.CGTYPE(ip) = mgtype
  1543.               ENDDO
  1544.               nprof = ip
  1545.               SEGADJ,CHAPRO
  1546.               CHAINF.ISCHPR(idt) = CHAPRO
  1547.               GOTO 300
  1548.             ENDIF
  1549.  
  1550. C---------MCHAML
  1551.             isea = 0
  1552.             DO ib = 1, MED_GTABLE
  1553.               mgtype  = MEDGTB(ib)
  1554.               DO ic = 1, MED_ETABLE
  1555.                 metype  = MEDETB(ic)
  1556.                 CALL mfdnpf(mfid, fname, numdt, numit, metype, mgtype,
  1557.      &                      lispro.DPNAME, lispro.LNAME, n4, mcret)
  1558.                 IF (mcret .NE. 0) THEN
  1559.                   moterr    = 'lirmed / mfdnpf'
  1560.                   interr(1) = mcret
  1561.                   CALL ERREUR(873)
  1562.                   GOTO 199
  1563.                 ENDIF
  1564.                 nprof = n4
  1565.       if (iimpi.eq.1972) then
  1566.         write(ioimp,*) ' MCHAML profil',nprof,idt,ip
  1567.       endif
  1568.                 IF (nprof.GT.0) THEN
  1569.                   DO ie = 1, nprof
  1570.                     ip = ip + 1
  1571.                     CHAPRO.CTYPE(ip)  = 'MCHAML  '
  1572.                     CHAPRO.CPRONA(ip) = lispro.DPNAME(ie)
  1573.                     CHAPRO.CETYPE(ip) = metype
  1574.                     CHAPRO.CGTYPE(ip) = mgtype
  1575.                   ENDDO
  1576.                   isea = 1
  1577.                 ENDIF
  1578.               ENDDO
  1579.             ENDDO
  1580.             IF (isea .EQ. 1) THEN
  1581.               IF (typobj .EQ. '        ') typobj = 'MCHAML  '
  1582.               IF (typobj .NE. 'MCHAML  ') THEN
  1583.                 moterr = ' ERREUR On voulait MCHAML mais on a '//typobj
  1584.                 CALL ERREUR(-385)
  1585.                 CALL ERREUR(21)
  1586.                 GOTO 199
  1587.               ENDIF
  1588.               nprof = ip
  1589.               SEGADJ,CHAPRO
  1590.               CHAINF.ISCHPR(idt) = CHAPRO
  1591.               GOTO 300
  1592.             ENDIF
  1593.  
  1594. C---------Sans profil
  1595. C---------CHPOINT
  1596.             metype = MED_NODE
  1597.             mgtype = MED_NONE
  1598.             CALL mfdnva(mfid, fname, numdt,numit, metype,mgtype,
  1599.      &                  n4, mcret)
  1600.             IF (mcret .NE. 0) THEN
  1601.               moterr    ='lirmed / mfdnva'
  1602.               interr(1) = mcret
  1603.               CALL ERREUR(873)
  1604.               GOTO 199
  1605.             ENDIF
  1606.             nprof = n4
  1607.             IF (nprof.GT.0) THEN
  1608.               IF (typobj .EQ. '        ') typobj = 'CHPOINT '
  1609.               IF (typobj .NE. 'CHPOINT ') THEN
  1610.                 moterr = 'ERREUR On voulait CHPOINT mais on a '//typobj
  1611.                 CALL ERREUR(-385)
  1612.                 CALL ERREUR(21)
  1613.                 GOTO 199
  1614.               ENDIF
  1615.       if (iimpi.eq.1972) then
  1616.         write(ioimp,*) ' CHPOINT sans profil',nprof,idt,ip
  1617.       endif
  1618.               CHAPRO.CTYPE(1)  = typobj
  1619.               CHAPRO.CPRONA(1) = ' '
  1620.               CHAPRO.CETYPE(1) = metype
  1621.               CHAPRO.CGTYPE(1) = mgtype
  1622.               nprof = 1
  1623.               SEGADJ,CHAPRO
  1624.               CHAINF.ISCHPR(idt) = CHAPRO
  1625.               GOTO 300
  1626.             ENDIF
  1627.  
  1628. C---------MCHAML
  1629.             isea = 0
  1630.             DO ib = 1, MED_GTABLE
  1631.               mgtype  = MEDGTB(ib)
  1632.               DO ic = 1, MED_ETABLE
  1633.                 metype  = MEDETB(ic)
  1634.                 CALL mfdnva(mfid,fname,numdt,numit,metype,mgtype,
  1635.      &                      n4,mcret)
  1636.                 IF (mcret .NE. 0) THEN
  1637.                   moterr    = 'lirmed / mfdnpf'
  1638.                   interr(1) = mcret
  1639.                   CALL ERREUR(873)
  1640.                   GOTO 199
  1641.                 ENDIF
  1642.                 n = n4
  1643.                 IF (n .GT. 0) THEN
  1644.                   ip = ip + 1
  1645.                   CHAPRO.CTYPE(ip)  = 'MCHAML'
  1646.                   CHAPRO.CPRONA(ip) = ' '
  1647.                   CHAPRO.CETYPE(ip) = metype
  1648.                   CHAPRO.CGTYPE(ip) = mgtype
  1649.                   isea = 1
  1650.                 ENDIF
  1651.               ENDDO
  1652.             ENDDO
  1653.             IF (isea .EQ. 1) THEN
  1654.               IF (typobj .EQ. ' ') typobj = 'MCHAML'
  1655.               IF (typobj .NE. 'MCHAML') THEN
  1656.                 moterr = 'LIRE MED - ERREUR : MCHAML demande mais '//
  1657.      &                   typobj//' lu'
  1658.                 CALL ERREUR(-385)
  1659.                 CALL ERREUR(21)
  1660.                 GOTO 199
  1661.               ENDIF
  1662.               nprof = ip
  1663.               SEGADJ,CHAPRO
  1664.               CHAINF.ISCHPR(idt) = CHAPRO
  1665.               GOTO 300
  1666.             ENDIF
  1667.  
  1668. C---------Champ non conforme
  1669.             IF (ip .EQ. 0) THEN
  1670.               moterr = 'LIRE MED - ERREUR : Champ non conforme'
  1671.               CALL ERREUR(-385)
  1672.               CALL ERREUR(21)
  1673.               GOTO 199
  1674.             ENDIF
  1675.  300        CONTINUE
  1676.           ENDDO
  1677.  
  1678. C-------Sortie d'un champ
  1679.           IF (ndt .EQ. 1) THEN
  1680.             isea = 0
  1681. C---------On cherche une syntaxe de sortie
  1682.             CALL MEDNML(2, 2, fname, cha64a, isca)
  1683.             IF (isca .EQ. 0) THEN
  1684.               cha64a = fname
  1685.             ENDIF
  1686. C---------On cherche une syntaxe de fusion
  1687.             IF (nbso .EQ. 0) THEN
  1688.               nbso = nbso + 1
  1689.               IF (nbso .GT. nbsor) THEN
  1690.                 nbsor = nbsor + 20
  1691.                 SEGADJ,SLSSOR
  1692.               ENDIF
  1693.             ELSE
  1694.               CALL PLACE(SLSSOR.CHANOM, nbso, iamo, cha64a)
  1695.       if (iimpi.eq.1972) then
  1696.         write(ioimp,*) 'Fusion ?',iamo,nbso,cha64a
  1697.       endif
  1698.               IF (iamo .EQ. 0) THEN
  1699.                 nbso = nbso + 1
  1700.                 IF (nbso .GT. nbsor) THEN
  1701.                   nbsor = nbsor + 20
  1702.                   SEGADJ,SLSSOR
  1703.                 ENDIF
  1704.               ELSE
  1705.                 cha8b = SLSSOR.CHATYP(iamo)
  1706.                 IF (cha8b .NE. typobj) THEN
  1707.                   moterr = '   ERREUR cha8b ('//cha8b//') different '//
  1708.      &                     'de typobj ('//typobj//')'
  1709.                   CALL ERREUR(-385)
  1710.                   CALL ERREUR(21)
  1711.                   GOTO 199
  1712.                 ENDIF
  1713.                 nbso = iamo
  1714.                 isea = 1
  1715.               ENDIF
  1716.             ENDIF
  1717. C---------On remplit l'information
  1718.             IF (isea .EQ. 0) THEN
  1719.               nbfus = 1
  1720.               SEGINI SLSFUS
  1721.               SLSFUS.CHAFUS(nbfus) = ia
  1722.               SLSSOR.CHATYP(nbso)  = typobj
  1723.               SLSSOR.CHANOM(nbso)  = cha64a
  1724.               SLSSOR.CHALIS(nbso)  = SLSFUS
  1725.             ELSE
  1726.               SLSFUS = SLSSOR.CHALIS(nbso)
  1727.               nbfus  = SLSFUS.CHAFUS(/1) + 1
  1728.               SEGADJ SLSFUS
  1729.               SLSFUS.CHAFUS(nbfus) = ia
  1730.             ENDIF
  1731. C-------Sortie d'une TABLE
  1732.           ELSE
  1733.             isea1 = 0
  1734.             isea2 = 0
  1735. C---------On cherche une syntaxe de sortie
  1736.             CALL MEDNML(2, 2, fname, cha64a, isca)
  1737.             IF (isca .EQ. 0) THEN
  1738.               cha64a = fname
  1739.             ENDIF
  1740.             CALL MEDNML(3, 3, fname, cha64b, iscb)
  1741.             IF (iscb .EQ. 0) THEN
  1742.               cha64b = fname
  1743.             ENDIF
  1744. C---------On cherche une syntaxe de fusion
  1745.             IF (nbso .EQ. 0) THEN
  1746.               nbso = nbso + 1
  1747.               IF (nbso .GT. nbsor) THEN
  1748.                 nbsor = nbsor + 20
  1749.                 SEGADJ SLSSOR
  1750.               ENDIF
  1751.             ELSE
  1752.               CALL PLACE(SLSSOR.CHANOM, nbso, iamo, cha64a)
  1753.               IF (iamo .EQ. 0) THEN
  1754.                 nbso = nbso + 1
  1755.                 IF (nbso .GT. nbsor) THEN
  1756.                   nbsor = nbsor + 20
  1757.                   SEGADJ SLSSOR
  1758.                 ENDIF
  1759.               ELSE
  1760.                 cha8b = SLSSOR.CHATYP(iamo)
  1761.                 IF (cha8b .NE. 'TABLE') THEN
  1762.                   moterr = 'LIRE MED - ERREUR objet TABLE mais on a'
  1763.      &                     //cha8b
  1764.                   CALL ERREUR(-385)
  1765.                   CALL ERREUR(21)
  1766.                   GOTO 199
  1767.                 ENDIF
  1768.                 nbso  = iamo
  1769.                 isea1 = 1
  1770.               ENDIF
  1771.             ENDIF
  1772. C---------On remplit l'information
  1773.             nbso1  = nbso
  1774.             nbsor1 = nbsor
  1775.  
  1776.             IF (isea1 .EQ. 0) THEN
  1777.               nbsor = 1
  1778.               SEGINI SLSSO1
  1779.               nbfus = 1
  1780.               SEGINI SLSFUS
  1781.               SLSFUS.CHAFUS(nbfus) = ia
  1782.               SLSSO1.CHATYP(nbsor) = typobj
  1783.               SLSSO1.CHANOM(nbsor) = cha64b
  1784.               SLSSO1.CHALIS(nbsor) = SLSFUS
  1785.               SLSSOR.CHATYP(nbso1) = 'TABLE'
  1786.               SLSSOR.CHANOM(nbso1) = cha64a
  1787.               SLSSOR.CHALIS(nbso1) = SLSSO1
  1788.             ELSE
  1789.               SLSSO1 = SLSSOR.CHALIS(nbso1)
  1790.               nbsor  = SLSSO1.CHALIS(/1)
  1791.               CALL PLACE(SLSSO1.CHANOM, nbsor, iamo, cha64b)
  1792.               IF (iamo .EQ. 0) THEN
  1793.                 nbsor = nbsor + 1
  1794.                 SEGADJ SLSSO1
  1795.               ELSE
  1796.                 cha8b = SLSSO1.CHATYP(iamo)
  1797.                 IF (cha8b .NE. typobj) THEN
  1798.                   moterr = '   ERREUR cha8b ('//cha8b//') different '//
  1799.      &                     'de typobj ('//typobj//')'
  1800.                   CALL ERREUR(-385)
  1801.                   CALL ERREUR(21)
  1802.                   GOTO 199
  1803.                 ENDIF
  1804.                 nbsor = iamo
  1805.                 isea2 = 1
  1806.               ENDIF
  1807.  
  1808.               IF (isea2 .EQ. 0) THEN
  1809.                 nbfus = 1
  1810.                 SEGINI SLSFUS
  1811.                 SLSFUS.CHAFUS(nbfus) = ia
  1812.                 SLSSO1.CHATYP(nbsor) = typobj
  1813.                 SLSSO1.CHANOM(nbsor) = cha64b
  1814.                 SLSSO1.CHALIS(nbsor) = SLSFUS
  1815.               ELSE
  1816.                 SLSFUS = SLSSO1.CHALIS(nbsor)
  1817.                 nbfus  = SLSFUS.CHAFUS(/1) + 1
  1818.                 SEGADJ SLSFUS
  1819.                 SLSFUS.CHAFUS(nbfus) = ia
  1820.               ENDIF
  1821.             ENDIF
  1822.  
  1823.             nbso  = nbso1
  1824.             nbsor = nbsor1
  1825.           ENDIF
  1826.  
  1827.         ENDDO
  1828.  
  1829. C***********************************************************************
  1830. C      Lecture des champs & Stockage dans la table
  1831. C***********************************************************************
  1832.         DO ia = 1, nbso
  1833.           typobj = SLSSOR.CHATYP(ia)
  1834.           cha64a = SLSSOR.CHANOM(ia)
  1835.           isor = 0
  1836.           inin = 1
  1837.           IF      (typobj .EQ. 'CHPOINT ') THEN
  1838.             SLSFUS = SLSSOR.CHALIS(ia)
  1839.             CALL LMDCHP(mfid, MTABLE, NBNOIN,SLSCHA,SLSFUS, inin, isor)
  1840.           ELSE IF (typobj .EQ. 'MCHAML  ') THEN
  1841.             SLSFUS = SLSSOR.CHALIS(ia)
  1842.             CALL LMDCHM(mfid, MTABLE, SLSCHA,SLSFUS, inin, isor)
  1843.           ELSE IF (typobj .EQ. 'TABLE   ') THEN
  1844.             SLSSO1 = SLSSOR.CHALIS(ia)
  1845.             CALL LMDTAB(mfid, MTABLE, NBNOIN,SLSCHA,SLSSO1, isor)
  1846.           ENDIF
  1847.           IF (IERR.NE.0) GOTO 199
  1848.       if (iimpi.eq.1972) then
  1849.         write(ioimp,*) ia,' nom ',cha64a,' type ',typobj,isor
  1850.       endif
  1851.           CALL ECCTAB(MTABLE,typmot,inin,floin,cha64a,login,inin,
  1852.      &                       typobj,inre,flore,charre,logre,isor)
  1853.         ENDDO
  1854.  
  1855.  100    CONTINUE
  1856. C***********************************************************************
  1857. C     Nettoyage
  1858. C***********************************************************************
  1859.  199    CONTINUE
  1860.         IF (MAITOT .GT. 0) THEN
  1861.           DO ii = 1, nbtype
  1862.             NUMLI8 = maitot.INUMLI(ii)
  1863.             IF (NUMLI8.GT.0) SEGSUP,NUMLI8
  1864.           ENDDO
  1865.         ENDIF
  1866.         IF (SFAMI .GT. 0) THEN
  1867.           infam = SFAMI.PFAMGR(/1)
  1868.           DO ii = 1, infam
  1869.             SFAMGR = SFAMI.PFAMGR(ii)
  1870.             IF (SFAMGR.GT.0) SEGSUP,SFAMGR
  1871.             SFAMI.PFAMGR(ii) = 0
  1872.             IPT1 = SFAMI.PFAMAI(ii)
  1873.             IF (IPT1.GT.0) SEGDES,IPT1
  1874.             SFAMI.PFAMAI(ii) = 0
  1875.           ENDDO
  1876.           SEGSUP,SFAMI
  1877.         ENDIF
  1878.         IF (SLSCHA .GT. 0) SEGSUP,SLSCHA
  1879.         IF (SLSSOR .GT. 0) SEGSUP,SLSSOR
  1880.         IF (ICOOR  .GT. 0) SEGSUP,ICOOR
  1881.  
  1882.         IF (IERR.NE.0) GOTO 9996
  1883.  
  1884.       ENDDO
  1885. C***********************************************************************
  1886. C* 8 - Fin de la Boucle
  1887. C***********************************************************************
  1888.       MEDTAB = MTABLE
  1889.  
  1890.  9996 CONTINUE
  1891.       IF (MAITOT .GT. 0) SEGSUP,MAITOT
  1892.       IF (LPOLY  .GT. 0) SEGSUP,LPOLY
  1893.       IF (LISPRO .GT. 0) SEGSUP,LISPRO
  1894.  9997 CONTINUE
  1895.       IF (LINOMA .GT. 0) SEGSUP,LINOMA
  1896.       IF (SAWORK .GT. 0) SEGSUP,SAWORK
  1897.  
  1898. C***********************************************************************
  1899. C  Fermeture du fichier .med
  1900. C***********************************************************************
  1901.  9998 CONTINUE
  1902.       CALL MFICLO(mfid, mcret)
  1903.       IF (mcret .NE. 0) THEN
  1904.         moterr    = 'lirmed / mficlo'
  1905.         interr(1) = mcret
  1906.         CALL ERREUR(873)
  1907. c*        MEDTAB = 0
  1908.       ENDIF
  1909.  
  1910. C***********************************************************************
  1911. C  Ecriture de la TABLE Resultat ou Remise a etat initial (si erreur)
  1912. C***********************************************************************
  1913.       IF (MEDTAB .GT. 0) THEN
  1914. c*        MTABLE = MEDTAB (on a deja cela)
  1915.         SEGDES,MTABLE
  1916.         CALL ECROBJ('TABLE   ',MTABLE)
  1917.       ELSE
  1918.         IF (MTABLE .GT. 0) SEGSUP,MTABLE
  1919.         IF (IDIM_REF.NE.0 .AND. IDIM_REF.NE.IDIM) THEN
  1920. c*        CHANGER de DIMENSION ? IDIM = IDIM_REF
  1921.         ENDIF 
  1922.         NBPTS = NBPTS_REF
  1923.         SEGADJ,MCOORD
  1924.       ENDIF
  1925.  
  1926.  9999 CONTINUE
  1927.       SEGACT,MCOORD*NOMOD
  1928.       if (iimpi.EQ.1972) then
  1929.         write(ioimp,*)
  1930.         write(ioimp,*) 'Sortie de LIRE "MED"'
  1931.         write(ioimp,*) '--------------------'
  1932.         write(ioimp,*)
  1933.       endif
  1934.  
  1935. c      RETURN
  1936.       END
  1937.  
  1938.  
  1939.  

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