Télécharger lirmed.eso

Retour à la liste

Numérotation des lignes :

  1. C LIRMED SOURCE CB215821 19/03/18 21:15:23 10161
  2. C***********************************************************************
  3. C NOM : lirmed.eso
  4. C DESCRIPTION : Sortie d'un maillage au format .med
  5. C***********************************************************************
  6. C HISTORIQUE : 21/12/2010 : CHAT : création de la subroutine
  7. C HISTORIQUE : 04/11/2013 : CB215821 : PASSAGE AU FORMAT 3.0 DE MED
  8. C HISTORIQUE : 05/01/2017 : CB215821 : GESTION DES ERREURS DE LECTURE
  9. C HISTORIQUE : 23/10/2017 : RPAREDES : LECTURE CHPOINT,MCHAML,PASAPAS
  10. C HISTORIQUE : 09/10/2018 : BERTHINC : SOUCIS SI TASSPO dans PARAVIS
  11. C HISTORIQUE :
  12. C HISTORIQUE :
  13. C HISTORIQUE :
  14. C***********************************************************************
  15. C Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  16. C en cas de modification de ce sous-programme afin de faciliter
  17. C la maintenance !
  18. C***********************************************************************
  19. C APPELÉ PAR : opérateur LIRE (lirefi.eso)
  20. C***********************************************************************
  21. C ENTRÉES : aucune
  22. C SORTIES : aucune
  23. C***********************************************************************
  24. C SYNTAXE (GIBIANE) :
  25. C
  26. C TAB1 = LIRE 'MED' 'fichier.med'
  27. C
  28. C***********************************************************************
  29. SUBROUTINE LIRMED
  30. IMPLICIT INTEGER(i-n)
  31. IMPLICIT REAL*8(a-h,o-z)
  32.  
  33. C **********************************************************************
  34. C MODIFICATION CLEMENT BERTHINIER MED_3.X.X
  35. C on met l'include spécifique du format MED
  36. C concaténation de med_parameter.hf77 et med.hf77
  37. C **********************************************************************
  38. -INC CCMED
  39. -INC CCOPTIO
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMLMOTS
  43. -INC CCGEOME
  44. -INC SMTABLE
  45. -INC SMCHPOI
  46. -INC SMCHAML
  47.  
  48. C Définition des entiers *4
  49. INTEGER*4 fid
  50. INTEGER*4 access
  51. INTEGER*4 cret
  52. INTEGER*4 sdim
  53. INTEGER*4 mdim
  54. INTEGER*4 naxis
  55.  
  56. INTEGER*4 major
  57. INTEGER*4 minor
  58. INTEGER*4 rel
  59. INTEGER*4 mtype
  60. INTEGER*4 stype
  61. INTEGER*4 atype
  62. INTEGER*4 etype
  63. INTEGER*4 gtype
  64. INTEGER*4 datype
  65. INTEGER*4 chgt
  66. INTEGER*4 tsf
  67. INTEGER*4 swm
  68. INTEGER*4 psize
  69. INTEGER*4 cs
  70. INTEGER*4 ptype
  71.  
  72. INTEGER*4 numdt
  73. INTEGER*4 numit
  74. INTEGER*4 nstep
  75. INTEGER*4 fnum
  76. INTEGER*4 cmode
  77. INTEGER*4 n, ncha4, nc4, ncomp4, nprof, nval, ntprof, npara4, dval
  78. INTEGER*4 type
  79. INTEGER*4 it,it1
  80.  
  81. C Définition des reels *8
  82. REAL*8 dt
  83.  
  84. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  85. CHARACTER*(MED_SNAME_SIZE) dtunit
  86.  
  87. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  88. CHARACTER*(MED_NAME_SIZE) name
  89. CHARACTER*(MED_NAME_SIZE) fam
  90. CHARACTER*(MED_NAME_SIZE) fname
  91. CHARACTER*(MED_NAME_SIZE) mname
  92. CHARACTER*(MED_NAME_SIZE) dname
  93.  
  94. C-----Chaines de Caractere de longueur MED_LNAME_SIZE=80
  95. CHARACTER*(MED_LNAME_SIZE) char80
  96.  
  97. C-----Chaines de Caractere de longueur MED_COMMENT_SIZE=200
  98. CHARACTER*(MED_COMMENT_SIZE) desc
  99. C ***** FIN
  100.  
  101. C ***** Déclaration des variable
  102. CHARACTER*8 cha8a, cha8b, charre, typobj
  103. CHARACTER*64 cha64a, cha64b
  104. LOGICAL ltelq, login, logre
  105. CHARACTER*72 medres
  106. EXTERNAL LONG
  107.  
  108. C ***** Déclaration des segments
  109. SEGMENT SANAME
  110. CHARACTER*(MED_SNAME_SIZE) ANAME(IDIM)
  111. ENDSEGMENT
  112. SEGMENT SAUNIT
  113. CHARACTER*(MED_SNAME_SIZE) AUNIT(IDIM)
  114. ENDSEGMENT
  115.  
  116. C-----Contiendra les MAILLAGES SIMPLES au sens de Cast3M
  117. C ntypel ==> Type d'élément au sens de Cast3M
  118. C IPOMAI ==> pointeur MAILLAGE SIMPLE
  119. C INUMLI ==> pointeur vers le tableau des numéros de famille de chaque éléments
  120. SEGMENT MAITOT
  121. INTEGER IPOMAI(ntypel)
  122. INTEGER INUMLI(ntypel)
  123. ENDSEGMENT
  124.  
  125. SEGMENT NUMLI8
  126. INTEGER NUMLIS(nbelem)
  127. ENDSEGMENT
  128.  
  129. C-----Contiendra les numéros des familles des noeuds
  130. SEGMENT SFANOE
  131. INTEGER NFANOE(nbpta)
  132. ENDSEGMENT
  133.  
  134. C-----SEGMENT contenant les informations sur les familles
  135. C infam ==> Indice de la famille
  136. C IFAMNU ==> Numéro de la famille
  137. C PFAMGR ==> Pointeur vers le SEGMENT SFAMGR : nom des groupes dans la famille
  138. C CFANOM ==> Nom de la famille
  139. C PFAMAI ==> Pointeur vers MELEME de la famille en question
  140. SEGMENT SFAMI
  141. INTEGER IFAMNU(infam)
  142. INTEGER PFAMGR(infam)
  143. CHARACTER*(MED_NAME_SIZE) CFANOM(infam)
  144. INTEGER PFAMAI(infam)
  145. ENDSEGMENT
  146.  
  147. C-----SEGMENT contenant les noms des groupes
  148. SEGMENT SFAMGR
  149. CHARACTER*(MED_LNAME_SIZE) CFGRN(ngroup)
  150. ENDSEGMENT
  151.  
  152. C-----SEGMENT contenant les groupes de noms dIFférents (Casse y compris)
  153. C CGRNOM ==> Nom des groupes dIFférents
  154. SEGMENT SGRTOT
  155. CHARACTER*(MED_NAME_SIZE) CGRNOM(ngrdif)
  156. ENDSEGMENT
  157.  
  158. SEGMENT ICOOR
  159. REAL*8 XCOO(isdim,nbpta)
  160. ENDSEGMENT
  161.  
  162. SEGMENT SINT4
  163. INTEGER INT4(itaill)
  164. ENDSEGMENT
  165.  
  166. C----- SEG SLSCHA
  167. C ncham : nombre de champs (CHPOINT ou MCHAML)
  168. C LISCHA : liste des noms de champs
  169. C LISMAI : liste des noms de maillages
  170. C LSCHIN : liste de SEG CHAINF (information)
  171. C LSPARA : liste de SEG CHAPAR (parametres)
  172. SEGMENT SLSCHA
  173. CHARACTER*(MED_NAME_SIZE) LISCHA(ncham), LISMAI(ncham)
  174. INTEGER LSCHIN(ncham), LSPARA(ncham)
  175. ENDSEGMENT
  176.  
  177. C----- SEG SLSSOR
  178. C nbsor : nombre de champs à sortir
  179. C CHATYP : type de champ (CHPOINT, MCHAML ou TABLE)
  180. C CHANOM : nom du champ
  181. C CHALIS : liste de champs dans un segment SLSFUS(CHPOINT ou MCHAML)
  182. C ou SLSSOR(TABLE)
  183. SEGMENT SLSSOR
  184. CHARACTER*8 CHATYP(nbsor)
  185. CHARACTER*(MED_NAME_SIZE) CHANOM(nbsor)
  186. INTEGER CHALIS(nbsor)
  187. ENDSEGMENT
  188. POINTEUR SLSSO1.SLSSOR
  189.  
  190. SEGMENT SLSFUS
  191. INTEGER CHAFUS(nbfus)
  192. ENDSEGMENT
  193.  
  194. SEGMENT CHAINF
  195. C nc : nombre de séquences de calcul dans le champ
  196. C ncomp : nombre de composantes
  197. C INUMDT : liste de numéros de pas de tps
  198. C INUMIT : liste de numéros d'iteration
  199. C ISCHPR : liste de SEG CHAPRO (profil)
  200. C XDT : liste de pas de tps
  201. C CNAME : liste de noms des composants
  202. C CUNIT : liste d'unités des composants
  203. INTEGER INUMDT(nc), INUMIT(nc), ISCHPR(nc)
  204. REAL*8 XDT(nc)
  205. CHARACTER*(MED_SNAME_SIZE) CNAME(ncomp), CUNIT(ncomp)
  206. ENDSEGMENT
  207.  
  208. C----- SEG CHAPAR
  209. C ncpars : nombre de paramètres par champ
  210. C CHAPAR : nom du paramètre
  211. C CPARVL : valeur du paramètre
  212. SEGMENT CHAPAR
  213. CHARACTER*(MED_SNAME_SIZE) CPARNM(ncpars)
  214. INTEGER CPARVL(ncpars)
  215. ENDSEGMENT
  216.  
  217. C----- SEG CHAPRO
  218. C nprof : nombre de profils
  219. C CTYPE : type de champ
  220. C CPRONA : nom du profil
  221. C CETYPE : entity type
  222. C CGTYPE : geometry type
  223. SEGMENT CHAPRO
  224. CHARACTER*8 CTYPE(nprof)
  225. CHARACTER*(MED_NAME_SIZE) CPRONA(nprof)
  226. INTEGER CETYPE(nprof), CGTYPE(nprof)
  227. ENDSEGMENT
  228.  
  229. C----- SEG LISPRO
  230. C ntprof : nombre total de profils
  231. C DPNAME : nom du profil
  232. C LNAME : localisation du profil
  233. SEGMENT LISPRO
  234. CHARACTER*(MED_NAME_SIZE) DPNAME(ntprof), LNAME(ntprof)
  235. ENDSEGMENT
  236.  
  237. C***********************************************************************
  238. C Initialisations
  239. C***********************************************************************
  240. SANAME = 0
  241. SAUNIT = 0
  242. MAITOT = 0
  243. NUMLI8 = 0
  244. SFANOE = 0
  245. SFAMI = 0
  246. SFAMGR = 0
  247. SGRTOT = 0
  248. ICOOR = 0
  249. SINT4 = 0
  250. SLSCHA = 0
  251. SLSSOR = 0
  252. SLSFUS = 0
  253. CHAINF = 0
  254. CHAPAR = 0
  255. LISPRO = 0
  256. CHAPRO = 0
  257. FDUMMY = 0.D0
  258.  
  259. C***********************************************************************
  260. C Debut de la lecture
  261. C***********************************************************************
  262. ltelq = .TRUE.
  263.  
  264. CALL LIRCHA(medres, 1, iretou)
  265. IF (ierr .NE. 0) THEN
  266. RETURN
  267. ENDIF
  268.  
  269. CALL LIROBJ('MLMOTS', MLMOT1, 0, iretou)
  270. IF (iretou .NE. 0) THEN
  271. CALL LIROBJ('MLMOTS', MLMOT2, 1, iretou)
  272. IF (ierr .NE. 0) THEN
  273. RETURN
  274. ENDIF
  275.  
  276. SEGACT MLMOT1, MLMOT2
  277. IF (MLMOT1.MOTS(/2) .NE. MLMOT2.MOTS(/2)) THEN
  278. CALL ERREUR(19)
  279. RETURN
  280. ENDIF
  281. ENDIF
  282. C-----Creation de la TABLE de resultats
  283. m = 0
  284. SEGINI MTABLE
  285. ncompg = 0
  286. ngrdif = 10
  287. SEGINI SGRTOT
  288.  
  289. C *** Ouverture d'un fichier MED 3.0
  290. iloh = LONG(medres)
  291. name = medres(1:iloh)
  292. access = MED_ACC_RDONLY
  293. cret = 0
  294.  
  295. CALL MFIOPE(fid, name, access, cret)
  296. IF (cret .NE. 0) THEN
  297. moterr = 'mfiope'
  298. interr(1) = cret
  299. CALL ERREUR(873)
  300. RETURN
  301. ENDIF
  302.  
  303. C *** Vérification de la compatibilité d'un fichier avec HDF et MED.
  304. CALL MFICOM (name, hdfok, medok, cret)
  305. IF(cret .NE. 0) THEN
  306. moterr = 'mficom'
  307. interr(1) = cret
  308. CALL ERREUR(873)
  309. RETURN
  310. ENDIF
  311.  
  312. C *** Lecture du numéro de version de la bibliothèque MED utilisée pour créer le fichier.
  313. CALL MFINVR (fid, major, minor, rel, cret)
  314. IF(cret .NE. 0) THEN
  315. moterr = 'mfinvr'
  316. interr(1) = cret
  317. CALL ERREUR(873)
  318. RETURN
  319. ENDIF
  320.  
  321. C *** On ne sait pas lire du MED anterieur a 3
  322. IF(major .LT. 3)THEN
  323. interr(1)=major
  324. interr(2)=minor
  325. interr(3)=rel
  326. CALL ERREUR(1087)
  327. RETURN
  328. ENDIF
  329.  
  330. C *** Lecture du nombre de maillages dans un fichier MED 3.0
  331. CALL MMHNMH(fid, n, cret)
  332. c write(6,*) 'Nombre de maillage lu dans le med' , n
  333. IF(cret .NE. 0) THEN
  334. moterr = 'mmhnmh'
  335. interr(1) = cret
  336. CALL ERREUR(873)
  337. RETURN
  338. ENDIF
  339.  
  340. nbmail = n
  341.  
  342. DO 666 i=1,nbmail
  343. C-------Lecture du nombre d'axes du repère des coorDOnnées du maillage
  344. it = i
  345. c write(6,*) 'Traitement du maillage ', it ,' / ' , nbmail
  346. CALL MMHNAX(fid, it, naxis, cret)
  347. IF(cret .NE. 0) THEN
  348. moterr = 'mmhnax'
  349. interr(1) = cret
  350. CALL ERREUR(873)
  351. RETURN
  352. ENDIF
  353.  
  354. imdim = naxis
  355.  
  356. C-------Changement de la dimension de l'espace en cas de necessité
  357. C-------J'utilise le GIBIANE pour le faire : "OPTI DIME imdim;"
  358. IF (IDIM .LT. imdim) THEN
  359. CALL ECRENT(imdim)
  360. CALL ECRCHA('DIME')
  361. CALL OPTION(1)
  362.  
  363. IF (ierr .NE. 0) THEN
  364. WRITE(IOIMP,*)'ERREUR de changement de dimension'
  365. CALL ERREUR(219)
  366. ENDIF
  367.  
  368. WRITE(IOIMP,*) ' '
  369. WRITE(IOIMP,*) 'Passage en DIMEnsion ',imdim
  370. WRITE(IOIMP,*) ' '
  371. ENDIF
  372.  
  373.  
  374. C-------Initialisation des SEGMENTs pour les Unités des Axes (Non renseignés dans notre cas)
  375. SEGINI SANAME
  376. SEGINI SAUNIT
  377.  
  378. CALL MMHMII(fid, it, name, sdim, mdim, mtype, desc, dtunit,
  379. & stype, nstep, atype, ANAME, AUNIT, cret)
  380. IF(cret .NE. 0) THEN
  381. moterr = 'mmhmii'
  382. interr(1) = cret
  383. CALL ERREUR(873)
  384. RETURN
  385. ENDIF
  386.  
  387. isdim = sdim
  388. itypem = mtype
  389.  
  390. SEGSUP SANAME
  391. SEGSUP SAUNIT
  392.  
  393. C ***** Lecture du nombre d'entités (Noeuds ici) dans un maillage MED 3.0
  394. c write(6,*) 'Lecture du nombre d entites (Noeuds ici) '
  395. numdt = MED_NO_DT
  396. numit = MED_NO_IT
  397. etype = MED_NODE
  398. gtype = 0
  399. datype = MED_COORDINATE
  400. cmode = MED_NODAL
  401. chgt = MED_FALSE
  402. tsf = MED_FALSE
  403.  
  404. CALL MMHNME(fid, name, numdt, numit, etype, gtype, datype,
  405. & cmode, chgt, tsf, n, cret)
  406. IF(cret .NE. 0) THEN
  407. moterr = 'mmhnme'
  408. interr(1) = cret
  409. CALL ERREUR(873)
  410. RETURN
  411. ENDIF
  412.  
  413. nbpta = n
  414. SEGINI ICOOR
  415.  
  416. C ***** Lecture des coordonnées des noeuds MED 3.0
  417. c write(6,*) 'Lecture des coordonnees des noeuds'
  418. numdt = MED_NO_DT
  419. numit = MED_NO_IT
  420. swm = MED_FULL_INTERLACE
  421.  
  422. CALL MMHCOR(fid, name, numdt, numit, swm, ICOOR.XCOO, cret)
  423. IF(cret .NE. 0) THEN
  424. moterr = 'mmhcor'
  425. interr(1) = cret
  426. CALL ERREUR(873)
  427. RETURN
  428. ENDIF
  429.  
  430. C-----Les coordonnées des noeuds lus sont placées dans le tableau XCOOR
  431. C-----du SEGMENTs MCOORD (SMCOORD.INC)
  432. SEGACT,MCOORD*MOD
  433. nbnoin = XCOOR(/1)/(IDIM+1)
  434. ndec = XCOOR(/1)
  435. NBPTS = nbpta + nbnoin
  436.  
  437. C-----Mise à jour du SEGMENT MCOORD
  438. SEGADJ MCOORD
  439. DO nbn=1,nbpta
  440. DO ind=1,isdim
  441. XCOOR(ndec+ind+(nbn-1)*(IDIM+1)) = ICOOR.XCOO(ind,nbn)
  442. ENDDO
  443. ENDDO
  444. SEGSUP ICOOR
  445. SEGDES MCOORD
  446. SEGACT MCOORD
  447.  
  448. ntypel = MED_GTABLE
  449. SEGINI MAITOT
  450.  
  451. C ***** Lecture des numéros de famille des noeuds pour générer les POI1
  452. c write(6,*) 'Lecture des numeros de famille des noeuds'
  453. SEGINI SFANOE
  454.  
  455. nbelem = nbpta
  456. SEGINI NUMLI8
  457.  
  458. numdt = MED_NO_DT
  459. numit = MED_NO_IT
  460. etype = MED_NODE
  461. gtype = 0
  462. itaill = NUMLI8.NUMLIS(/1)
  463.  
  464. SEGINI,SINT4
  465. CALL MHFNR4(fid, name, numdt, numit, etype, gtype,
  466. & NUMLI8.NUMLIS, SINT4.INT4, cret, itaill)
  467. SEGSUP,SINT4
  468. IF(cret.GT.0) THEN
  469. moterr = 'mhfnr4'
  470. interr(1) = cret
  471. CALL ERREUR(873)
  472. RETURN
  473. ENDIF
  474.  
  475. C-----Création du MAILLAGE SIMPLE de POI1
  476. c write(6,*) 'Creation du MAILLAGE SIMPLE de POI1'
  477. nbnn = 1
  478. nbelem = nbpta
  479. nbsous = 0
  480. nbref = 0
  481. SEGINI IPT1
  482. IPT1.ITYPEL = 1
  483. DO indel=1,nbelem
  484. IPT1.ICOLOR(indel) = idcoul
  485. C-------La connectivité lue est décalée si des noeuds existaient avant
  486. IPT1.NUM(nbnn,indel) = indel+nbnoin
  487. ENDDO
  488.  
  489. nbtype=1
  490. C-----Sauvegarde du pointeur vers le MELEME simple
  491. MAITOT.IPOMAI(nbtype) = IPT1
  492. C-----Sauvegarde du pointeur vers le tableau des numéros de famille de chaque noeud de ce MAILLAGE SIMPLE de POI1
  493. MAITOT.INUMLI(nbtype) = NUMLI8
  494.  
  495. C-----Boucle sur tous les types d'éléments autre que POI1 (déjà traités)
  496. DO itypem=1,MED_GTABLE
  497.  
  498. C ***** Lecture du nombre d'entités (Eléments ici) en balayant tous les
  499. C ***** MAILLAGES SIMPLES d'un maillage MED 3.0
  500. c write(6,*) 'Lecture du nombre d entités', itypem
  501. numdt = MED_NO_DT
  502. numit = MED_NO_IT
  503. etype = MED_CELL
  504. gtype = MEDGTB(itypem)
  505. datype = MED_CONNECTIVITY
  506. cmode = MED_NODAL
  507. chgt = MED_FALSE
  508. tsf = MED_FALSE
  509. CALL MMHNME(fid , name, numdt, numit, etype, gtype, datype,
  510. & cmode, chgt, tsf , n, cret)
  511. IF(cret .NE. 0) THEN
  512. moterr = 'mmhnme'
  513. interr(1) = cret
  514. CALL ERREUR(873)
  515. RETURN
  516. ENDIF
  517.  
  518. IF(n .NE. 0) THEN
  519. nbtype=nbtype+1
  520.  
  521. nbnn = NBNNE(MDICLA(MEDGTB(itypem)))
  522. nbelem = n
  523. nbsous = 0
  524. nbref = 0
  525. SEGINI IPT1
  526.  
  527. IPT1.ITYPEL = MDICLA(MEDGTB(itypem))
  528. DO indel=1,nbelem
  529. IPT1.ICOLOR(indel) = idcoul
  530. ENDDO
  531.  
  532. C ***** Lecture des connectivités des éléments
  533. c write(6,*) 'Lecture des connectivités des éléments'
  534. numdt = MED_NO_DT
  535. numit = MED_NO_IT
  536. etype = MED_CELL
  537. gtype = MEDGTB(itypem)
  538. cmode = MED_NODAL
  539. swm = MED_FULL_INTERLACE
  540. itaill= nbnn*nbelem
  541. SEGINI SINT4
  542. CALL MHCYR4(fid, name, numdt, numit, etype, gtype,
  543. & cmode, swm,IPT1.NUM,SINT4.INT4,cret,itaill)
  544. SEGSUP,SINT4
  545. IF(cret .NE. 0) THEN
  546. moterr = 'mhcyr4'
  547. interr(1) = cret
  548. CALL ERREUR(873)
  549. RETURN
  550. ENDIF
  551.  
  552. C---------La connectivité lue est décalée si des noeuds existaient avant
  553. IF(nbnoin .NE. 0) THEN
  554. DO jou=1,nbelem
  555. DO iou=1,nbnn
  556. IPT1.NUM(iou,jou) = IPT1.NUM(iou,jou)+nbnoin
  557. ENDDO
  558. ENDDO
  559. ENDIF
  560.  
  561. C---------Passage de la connectivité MED 3.0 à Cast3M
  562. CALL MEDTRA(IPT1, 2)
  563.  
  564. C---------Sauvegarde du pointeur vers le MELEME simple
  565. MAITOT.IPOMAI(nbtype)=IPT1
  566.  
  567. C ***** Lecture des numéros de famille des types d'éléments : type MEDGTB(itypem)
  568. SEGINI NUMLI8
  569. numdt = MED_NO_DT
  570. numit = MED_NO_IT
  571. etype = MED_CELL
  572. gtype = MEDGTB(itypem)
  573. itaill = NUMLI8.NUMLIS(/1)
  574. SEGINI SINT4
  575. CALL mhfnr4 (fid, name, numdt, numit, etype, gtype,
  576. & NUMLI8.NUMLIS, SINT4.INT4, cret, itaill)
  577. IF(cret .NE. 0) THEN
  578. moterr = 'mhfnr4'
  579. interr(1) = cret
  580. CALL ERREUR(873)
  581. RETURN
  582. ENDIF
  583. SEGSUP,SINT4
  584.  
  585. C---------Sauvegarde du pointeur vers le tableau des numéros de famille de chaque éléments de ce MAILLAGE SIMPLE
  586. MAITOT.INUMLI(nbtype) = NUMLI8
  587. ENDIF
  588. ENDDO
  589.  
  590.  
  591. C-----Le SEGMENT contenant toutes les infos des maillages est ajusté
  592. ntypel = nbtype
  593. SEGADJ MAITOT
  594.  
  595. C ***** Création d'un MAILLAGE COMPLEXE contenant tous les MELEME SIMPLES
  596. nbref = 0
  597. nbsous = nbtype-1
  598. nbelem = 0
  599. nbnn = 0
  600.  
  601. SEGINI IPT1
  602. DO indsou=1,nbtype-1
  603. IPT2 = MAITOT.IPOMAI(indsou+1)
  604. IPT1.lisous(indsou) = IPT2
  605. ENDDO
  606. SEGDES IPT1
  607.  
  608.  
  609. C-----Ecriture dans la table du MAILLAGE complet des FAMILLES => Partition
  610. c write(6,*) 'Ecriture dans la table du maillage ' ,name
  611. CALL ECCTAB(MTABLE,'MOT ',0 ,FDUMMY,name,.FALSE.,0 ,
  612. & 'MAILLAGE',0 ,FDUMMY,' ',.FALSE.,IPT1)
  613.  
  614. C ***** Lecture du nombre de famille dans un maillage
  615. CALL MFANFA(fid, name, n, cret)
  616. c write(6,*) 'Lecture du nombre de famille dans un maillage ' ,n
  617. IF(cret .NE. 0) THEN
  618. moterr = 'mfanfa'
  619. interr(1) = cret
  620. CALL ERREUR(873)
  621. RETURN
  622. ENDIF
  623.  
  624. infam = n
  625. SEGINI SFAMI
  626.  
  627.  
  628. DO ifam=1,infam
  629. c write(6,*) 'Famille ' ,ifam, ' / ' , infam
  630. C ***** Lecture du nombre de groupe dans une famille
  631. it1 = ifam
  632.  
  633. CALL MFANFG(fid, name, it1, n, cret)
  634. c write(6,*) 'Lecture du nombre de groupe dans une famille ',name,n
  635. IF(cret .NE. 0) THEN
  636. moterr = 'mfanfg'
  637. interr(1) = cret
  638. CALL ERREUR(873)
  639. RETURN
  640. ENDIF
  641. ngroup = n
  642.  
  643. SEGINI SFAMGR
  644.  
  645. C ***** Lecture des informations sur une famille
  646. ind = ifam
  647.  
  648. CALL MFAFAI(fid, name, ind, fam, fnum, SFAMGR.CFGRN, cret)
  649. c write(6,*) ' Lecture des informations sur une famille '
  650. c write(6,*) 'ind =' ,ind
  651. c write(6,*) 'fam=' , fam
  652. c write(6,*) 'fnum' , fnum
  653. c write(6,*) 'sfamgr', SFAMGR.CFGRN
  654. IF(cret .NE. 0) THEN
  655. moterr = 'mfafai'
  656. interr(1) = cret
  657. C CALL ERREUR(873)
  658. C RETURN
  659. ENDIF
  660.  
  661. SFAMI.IFAMNU(ifam) = fnum
  662. SFAMI.PFAMGR(ifam) = SFAMGR
  663. SFAMI.CFANOM(ifam) = fam
  664.  
  665.  
  666. C-------Construction à la volée de la liste des groupes différents
  667. IF (ngroup .GT. 0) THEN
  668. C---------Cas ou le nombre de groupe n'est pas nul
  669. IF (ncompg .EQ. 0) THEN
  670. C-----------Cas où la liste est vierge ==> Ajout de tous les noms
  671. ncompg = ncompg + ngroup
  672.  
  673. C-----------Ajustement intermédiaire (éventuel) du SEGMENT SGRTOT
  674. IF (ncompg.GT.ngrdif) THEN
  675. ngrdif = ncompg * 2 + 10
  676. SEGADJ SGRTOT
  677. ENDIF
  678.  
  679. DO igroup=1,ngroup
  680. SGRTOT.CGRNOM(igroup) = SFAMGR.CFGRN(igroup)
  681. ENDDO
  682. ELSE
  683. C-----------Cas où des noms de groupes existent déjà ==> Comparaison aux noms existants
  684. DO igroup=1,ngroup
  685. iverif = 0
  686. DO IGEXIS=1,ncompg
  687. IF(SFAMGR.CFGRN(igroup).EQ.SGRTOT.CGRNOM(IGEXIS))THEN
  688. iverif = 1
  689. ENDIF
  690. ENDDO
  691.  
  692. IF(iverif .EQ. 0) THEN
  693. C---------------Ajout du groupe s'il n'existe pas déjà
  694. ncompg = ncompg + 1
  695.  
  696. C---------------Ajustement intermédiaire (éventuel) du SEGMENT SGRTOT
  697. IF (ncompg .GT. ngrdif) THEN
  698. ngrdif = ngrdif * 2
  699. SEGADJ SGRTOT
  700. ENDIF
  701. SGRTOT.CGRNOM(ncompg) = SFAMGR.CFGRN(igroup)
  702. ENDIF
  703. ENDDO
  704. ENDIF
  705. ENDIF
  706. ENDDO
  707.  
  708. C-----Ajustement final (éventuel) du SEGMENT SGRTOT
  709. IF (ncompg .NE. ngrdif) THEN
  710. ngrdif = ncompg
  711. SEGADJ SGRTOT
  712. ENDIF
  713.  
  714. C ***** Reconstitution des dépendances des maillages dans Cast3M
  715. C-----creation des maillages des familles (POI1 compris)
  716. nbref = 0
  717. nbsous = 0
  718. IPT3 = 0
  719.  
  720. C-----Boucle sur les familles lues
  721. DO ifam=1,infam
  722. inufam = SFAMI.IFAMNU(ifam)
  723. IPT3 = 0
  724.  
  725. C-------Boucle sur les types d'éléments
  726. DO itype=1,nbtype
  727. C---------Chargement du numéro de famille de la ifam ième famille
  728. NUMLI8 = MAITOT.INUMLI(itype)
  729. nbelem = 0
  730.  
  731. DO ielem=1,NUMLI8.NUMLIS(/1)
  732. C-----------Calcule le nombre d'élément du type itype appartenant à la famille ifam
  733. IF (NUMLI8.NUMLIS(ielem) .EQ. inufam) THEN
  734. nbelem = nbelem+1
  735. ENDIF
  736. ENDDO
  737.  
  738.  
  739. IF(nbelem .GT. 0) THEN
  740. C-----------Cas où un maillage d'éléments de type itype est a créer pour la famille ifam
  741. C-----------Chargement du maillage complet du type d'élément itype
  742. IPT1 = MAITOT.IPOMAI(itype)
  743. nbnn = IPT1.num(/1)
  744.  
  745. C-----------Création du nouveau maillage composé de la partition des éléments de IPT1 appartenant à la famille ifam
  746. SEGINI IPT2
  747. iel = 0
  748. IPT2.itypel = IPT1.itypel
  749. DO ielem=1,NUMLI8.NUMLIS(/1)
  750. IF(NUMLI8.NUMLIS(ielem) .EQ. inufam) THEN
  751. iel = iel+1
  752. DO iconn=1,nbnn
  753. IPT2.num(iconn,iel)=IPT1.num(iconn,ielem)
  754. ENDDO
  755. IPT2.icolor(iel) = idcoul
  756. ENDIF
  757. ENDDO
  758.  
  759. C-----------Création du MELEME COMPLEXE s'il y a lieu
  760. IF (IPT3 .EQ. 0) THEN
  761. IPT3=IPT2
  762. ELSE
  763. C-------------Fusion des maillages IPT3 et IPT2 dans IPT4
  764. CALL FUSE(IPT3, IPT2, IPT4, ltelq)
  765. IPT3 = IPT4
  766. ENDIF
  767. ENDIF
  768. ENDDO
  769.  
  770. SFAMI.PFAMAI(ifam) = IPT3
  771. ENDDO
  772. 666 CONTINUE
  773.  
  774. C-----creation des maillages des groupes : OBJETS NOMMES DANS CAST3M
  775. DO igroup=1,ngrdif
  776. char80 = SGRTOT.CGRNOM(igroup)
  777. IPT3 = 0
  778. DO 115 ifam=1,infam
  779. SFAMGR = SFAMI.PFAMGR(ifam)
  780. DO inomgr=1,SFAMGR.CFGRN(/2)
  781. IF (char80 .EQ. SFAMGR.CFGRN(inomgr)) THEN
  782. IF(IPT3 .EQ. 0)THEN
  783. IPT3 = SFAMI.PFAMAI(ifam)
  784. ELSE
  785. IPT2 = SFAMI.PFAMAI(ifam)
  786. C---------------Fusion des maillages IPT3 et IPT2 dans IPT4
  787. CALL FUSE(IPT3, IPT2, IPT4, ltelq)
  788. IPT3 = IPT4
  789. ENDIF
  790. GOTO 115
  791. ENDIF
  792. ENDDO
  793. 115 CONTINUE
  794.  
  795.  
  796. C-----Ecriture dans la table du TYPE IMO(2:9)
  797. IF (char80 .NE. ' ') THEN
  798. CALL ECCTAB(MTABLE,'MOT ',0 ,FDUMMY,char80,.FALSE.,0 ,
  799. & 'MAILLAGE',0 ,FDUMMY,' ',.FALSE.,IPT3)
  800. ENDIF
  801. ENDDO
  802.  
  803.  
  804. C***********************************************************************
  805. C Ménage dans les SEGMENTS
  806. C***********************************************************************
  807. IF(MLMOT1 .NE. 0) THEN
  808. SEGDES MLMOT1,MLMOT2
  809. ENDIF
  810.  
  811. SEGSUP MAITOT
  812.  
  813. DO iou=1,infam
  814. SFAMGR = SFAMI.PFAMGR(iou)
  815. SEGSUP SFAMGR
  816.  
  817. IPT1 = SFAMI.PFAMAI(iou)
  818. IF(IPT1 .GT. 0) THEN
  819. SEGDES IPT1
  820. ENDIF
  821. ENDDO
  822. SEGSUP SFAMI
  823. SEGSUP SGRTOT
  824. SEGSUP SFANOE
  825. SEGSUP NUMLI8
  826.  
  827. C***********************************************************************
  828. C Lecture des champs
  829. C***********************************************************************
  830. C ***** Nombre de champs a lire
  831. SLSCHA = 0
  832. CALL mfdnfd(fid, ncha4, cret)
  833. IF(cret .NE. 0) THEN
  834. moterr = 'mfdnfd'
  835. interr(1) = cret
  836. CALL ERREUR(873)
  837. RETURN
  838. ENDIF
  839.  
  840. ncham=ncha4
  841.  
  842. IF (ncham .EQ. 0) GOTO 999
  843. SEGINI SLSCHA
  844. DO incham=1,ncham
  845. C-------Nombre de composantes d'un champ
  846. it=incham
  847. CALL mfdnfc(fid, it, ncomp4, cret)
  848. IF(cret .NE. 0) THEN
  849. moterr ='mfdnfc'
  850. interr(1) = cret
  851. CALL ERREUR(873)
  852. RETURN
  853. ENDIF
  854.  
  855. C-------Information sur le champ
  856. nc=1
  857. ncomp=ncomp4
  858. SEGINI,CHAINF
  859. CALL mfdfdi(fid, it, fname, mname, lmesh, type, CHAINF.CNAME,
  860. & CHAINF.CUNIT, dtunit, nc4, cret)
  861. IF(cret .NE. 0) THEN
  862. moterr ='mfdfdi'
  863. interr(1) = cret
  864. CALL ERREUR(873)
  865. RETURN
  866. ENDIF
  867. nc=nc4
  868. IF (nc .GT. 1) THEN
  869. SEGADJ,CHAINF
  870. ELSEIF (nc .EQ. 0) THEN
  871. WRITE(IOIMP,*) ' ERREUR nc=0'
  872. CALL ERREUR(21)
  873. RETURN
  874. ENDIF
  875.  
  876. C Certains fichiers MED ont des CHAMPS sans composantes nommees !
  877. DO icomp=1,ncomp
  878. IF(CHAINF.CNAME(icomp) .EQ. ' ') THEN
  879. CHAINF.CNAME='SCAL'
  880. ENDIF
  881. ENDDO
  882.  
  883. DO iinc=1,nc
  884. C---------Lecture des informations caractérisant une séquence de calcul
  885. it1=iinc
  886. CALL mfdcsi(fid, fname, it1, numdt, numit, dt, cret)
  887. IF(cret .NE. 0) THEN
  888. moterr ='mfdcsi'
  889. interr(1) = cret
  890. CALL ERREUR(873)
  891. RETURN
  892. ENDIF
  893. CHAINF.INUMDT(iinc) = numdt
  894. CHAINF.INUMIT(iinc) = numit
  895. CHAINF.XDT(iinc) = dt
  896. ENDDO
  897.  
  898. SLSCHA.LISCHA(incham) = fname
  899. c write(IOIMP,*) 'ecriture de ', mname, 'dans LISMAI', incham
  900. SLSCHA.LISMAI(incham) = mname
  901. SLSCHA.LSCHIN(incham) = CHAINF
  902. SLSCHA.LSPARA(incham) = 0
  903. ENDDO
  904.  
  905. C ***** Recherche des paramètres numériques
  906. numdt = MED_NO_DT
  907. numit = MED_NO_IT
  908. CALL mprnpr(fid, npara4, cret)
  909. IF(cret .NE. 0) THEN
  910. moterr ='mprnpr'
  911. interr(1) = cret
  912. CALL ERREUR(873)
  913. RETURN
  914. ENDIF
  915.  
  916. nparam=npara4
  917. DO iparam=1,nparam
  918. it1 = iparam
  919. CALL mprpri(fid, it1, dname, ptype, desc, dtunit, nstep, cret)
  920. IF (cret .NE. 0) THEN
  921. moterr ='mprpri'
  922. interr(1) = cret
  923. CALL ERREUR(873)
  924. RETURN
  925. ENDIF
  926.  
  927. C-------On regarde si ça correspond à un champ existant
  928. CALL MEDNML(-1, 1, dname, cha64a, isca)
  929. CALL MEDNML(-2, 1, dname, cha64b, iscb)
  930. IF (isca .GT. 0 .AND. iscb .GT. 0) THEN
  931. CALL PLACE(SLSCHA.LISCHA, ncham, iamo, cha64b)
  932.  
  933. IF (iamo .GT. 0) THEN
  934. CALL mprivr(fid, dname, numdt, numit, dval, cret)
  935. IF (cret .NE. 0) THEN
  936. moterr ='mprivr'
  937. interr(1) = cret
  938. CALL ERREUR(873)
  939. RETURN
  940. ENDIF
  941. CHAPAR = SLSCHA.LSPARA(iamo)
  942. IF (CHAPAR .EQ. 0) THEN
  943. ncpars = 1
  944. SEGINI CHAPAR
  945. ELSE
  946. ncpars = CHAPAR.CPARVL(/1) + 1
  947. SEGADJ CHAPAR
  948. ENDIF
  949. CHAPAR.CPARNM(ncpars) = cha64a(1:isca)
  950. CHAPAR.CPARVL(ncpars) = dval
  951. SLSCHA.LSPARA(iamo) = CHAPAR
  952. ENDIF
  953. ENDIF
  954. ENDDO
  955.  
  956. C ***** Recherche des profils et mise en place des champs à sortir
  957. C-----Initialisation
  958. nbsor = 0
  959. nbso = 0
  960. SEGINI SLSSOR
  961.  
  962. C-----Nombre de profils
  963. CALL mpfnpf(fid, ntprof, cret)
  964. IF(cret .NE. 0) THEN
  965. moterr ='mpfnpf'
  966. interr(1) = cret
  967. CALL ERREUR(873)
  968. RETURN
  969. ENDIF
  970.  
  971. IF (ntprof .EQ. 0) ntprof = MED_GTABLE*MED_ETABLE
  972.  
  973. C-----Boucle sur tous les pas de tps de chaque champ. On suppose qu'un
  974. C-----champ peut être défini soit sur profil soit sur le maillage total
  975. SEGINI LISPRO
  976. DO ia=1,ncham
  977. fname = SLSCHA.LISCHA(ia)
  978. CHAINF = SLSCHA.LSCHIN(ia)
  979. ndt = CHAINF.INUMDT(/1)
  980. cha8a = ' '
  981.  
  982. DO 300 idt=1,ndt
  983. numdt = CHAINF.INUMDT(idt)
  984. numit = CHAINF.INUMIT(idt)
  985. ip = 0
  986. nprof = ntprof*MED_GTABLE*MED_ETABLE
  987. SEGINI CHAPRO
  988.  
  989. C---------Avec profil
  990. C---------CHPOINT
  991. etype = MED_NODE
  992. gtype = MED_NONE
  993.  
  994. CALL mfdnpf(fid, fname, numdt, numit, etype, gtype,
  995. & LISPRO.DPNAME, LISPRO.LNAME, nprof, cret)
  996. IF(cret .NE. 0) THEN
  997. moterr ='mfdnpf'
  998. interr(1) = cret
  999. CALL ERREUR(873)
  1000. RETURN
  1001. ENDIF
  1002. IF (nprof .GT. 0) THEN
  1003. DO ib=1,nprof
  1004. ip = ip + 1
  1005. CHAPRO.CTYPE(ip) ='CHPOINT'
  1006. CHAPRO.CPRONA(ip) = LISPRO.DPNAME(ib)
  1007. CHAPRO.CETYPE(ip) = etype
  1008. CHAPRO.CGTYPE(ip) = gtype
  1009. ENDDO
  1010. IF (cha8a .EQ. ' ') THEN
  1011. cha8a = 'CHPOINT'
  1012. ELSE
  1013. IF (cha8a .NE. 'CHPOINT') THEN
  1014. WRITE(IOIMP,*) ' ERREUR On voulait CHPOINT mais on a'
  1015. & ,cha8a
  1016. CALL ERREUR(21)
  1017. RETURN
  1018. ENDIF
  1019. ENDIF
  1020. nprof = ip
  1021. SEGADJ CHAPRO
  1022. CHAINF.ISCHPR(idt) = CHAPRO
  1023. GOTO 300
  1024. ENDIF
  1025.  
  1026. C---------MCHAML
  1027. isea = 0
  1028. DO ib=1,MED_GTABLE
  1029. DO ic=1,MED_ETABLE
  1030. etype = MEDETB(ic)
  1031. gtype = MEDGTB(ib)
  1032. CALL mfdnpf(fid, fname, numdt, numit, etype, gtype,
  1033. & LISPRO.DPNAME, LISPRO.LNAME, nprof, cret)
  1034. IF(cret .NE. 0) THEN
  1035. moterr ='mfdnpf'
  1036. interr(1) = cret
  1037. CALL ERREUR(873)
  1038. RETURN
  1039. ENDIF
  1040. IF (nprof.GT.0) THEN
  1041. DO ie=1,nprof
  1042. ip = ip + 1
  1043. CHAPRO.CTYPE(ip) = 'MCHAML'
  1044. CHAPRO.CPRONA(ip) = LISPRO.DPNAME(ie)
  1045. CHAPRO.CETYPE(ip) = etype
  1046. CHAPRO.CGTYPE(ip) = gtype
  1047. ENDDO
  1048. isea = 1
  1049. ENDIF
  1050. ENDDO
  1051. ENDDO
  1052. IF (isea .EQ. 1) THEN
  1053. IF (cha8a .EQ. ' ') THEN
  1054. cha8a = 'MCHAML'
  1055. ELSE
  1056. IF (cha8a .NE. 'MCHAML') THEN
  1057. WRITE(IOIMP,*) ' ERREUR On voulait MCHAML mais on a'
  1058. & ,cha8a
  1059. CALL ERREUR(21)
  1060. RETURN
  1061. ENDIF
  1062. ENDIF
  1063. nprof = ip
  1064. SEGADJ CHAPRO
  1065. CHAINF.ISCHPR(idt) = CHAPRO
  1066. GOTO 300
  1067. ENDIF
  1068.  
  1069. C---------Sans profil
  1070. C---------CHPOINT
  1071. etype = MED_NODE
  1072. gtype = MED_NONE
  1073. CALL mfdnva(fid, fname, numdt, numit, etype, gtype, n, cret)
  1074. IF(cret .NE. 0) THEN
  1075. moterr ='mfdnva'
  1076. interr(1) = cret
  1077. CALL ERREUR(873)
  1078. RETURN
  1079. ENDIF
  1080. IF (n.GT.0) THEN
  1081. CHAPRO.CTYPE(1) = 'CHPOINT'
  1082. CHAPRO.CPRONA(1) = ' '
  1083. CHAPRO.CETYPE(1) = etype
  1084. CHAPRO.CGTYPE(1) = gtype
  1085. IF (cha8a .EQ. ' ') THEN
  1086. cha8a = 'CHPOINT'
  1087. ELSE
  1088. IF (cha8a .NE. 'CHPOINT') THEN
  1089. WRITE(IOIMP,*) ' ERREUR On voulait CHPOINT mais on a'
  1090. & ,cha8a
  1091. CALL ERREUR(21)
  1092. RETURN
  1093. ENDIF
  1094. ENDIF
  1095. nprof = 1
  1096. SEGADJ CHAPRO
  1097. CHAINF.ISCHPR(idt) = CHAPRO
  1098. GOTO 300
  1099. ENDIF
  1100.  
  1101. C---------MCHAML
  1102. isea = 0
  1103. DO ib=1,MED_GTABLE
  1104. DO ic=1,MED_ETABLE
  1105. etype = MEDETB(ic)
  1106. gtype = MEDGTB(ib)
  1107. CALL mfdnva(fid,fname,numdt,numit,etype,gtype,n,cret)
  1108. IF(cret .NE. 0) THEN
  1109. moterr ='mfdnpf'
  1110. interr(1) = cret
  1111. CALL ERREUR(873)
  1112. RETURN
  1113. ENDIF
  1114. IF (n .GT. 0) THEN
  1115. ip = ip + 1
  1116. CHAPRO.CTYPE(ip) = 'MCHAML'
  1117. CHAPRO.CPRONA(ip) = ' '
  1118. CHAPRO.CETYPE(ip) = etype
  1119. CHAPRO.CGTYPE(ip) = gtype
  1120. isea = 1
  1121. ENDIF
  1122. ENDDO
  1123. ENDDO
  1124. IF (isea .EQ. 1) THEN
  1125. IF (cha8a .EQ. ' ') THEN
  1126. cha8a = 'MCHAML'
  1127. ELSE
  1128. IF (cha8a .NE. 'MCHAML') THEN
  1129. WRITE(IOIMP,*) ' ERREUR On voulait MCHAML mais on a',
  1130. & cha8a
  1131. CALL ERREUR(21)
  1132. RETURN
  1133. ENDIF
  1134. ENDIF
  1135. nprof = ip
  1136. SEGADJ CHAPRO
  1137. CHAINF.ISCHPR(idt) = CHAPRO
  1138. GOTO 300
  1139. ENDIF
  1140.  
  1141. C---------Champ non conforme
  1142. IF (ip .EQ. 0) THEN
  1143. PRINT *,'SUBROUTINE LIRMED : Champ non conforme'
  1144. CALL ERREUR(21)
  1145. RETURN
  1146. ENDIF
  1147. 300 CONTINUE
  1148.  
  1149. C-------Sortie d'un champ
  1150. IF (ndt .EQ. 1) THEN
  1151. isea = 0
  1152. C---------On cherche une syntaxe de sortie
  1153. CALL MEDNML(2, 2, fname, cha64a, isca)
  1154. IF (isca .EQ. 0) THEN
  1155. cha64a = fname
  1156. ENDIF
  1157. C---------On cherche une syntaxe de fusion
  1158. IF (nbso .EQ. 0) THEN
  1159. nbso = nbso + 1
  1160. IF (nbso .GT. nbsor) THEN
  1161. nbsor = nbsor + 20
  1162. SEGADJ SLSSOR
  1163. ENDIF
  1164. ELSE
  1165. CALL PLACE(SLSSOR.CHANOM, nbso, iamo, cha64a)
  1166. IF (iamo .EQ. 0) THEN
  1167. nbso = nbso + 1
  1168. IF (nbso .GT. nbsor) THEN
  1169. nbsor = nbsor + 20
  1170. SEGADJ SLSSOR
  1171. ENDIF
  1172. ELSE
  1173. cha8b = SLSSOR.CHATYP(iamo)
  1174. IF (cha8b .NE. cha8a) THEN
  1175. WRITE(IOIMP,*) ' ERREUR cha8b different de cha8a'
  1176. WRITE(IOIMP,*) ' ', cha8a, cha8b
  1177. CALL ERREUR(21)
  1178. RETURN
  1179. ENDIF
  1180. nbso = iamo
  1181. isea = 1
  1182. ENDIF
  1183. ENDIF
  1184. C---------On rempli l'information
  1185. IF (isea .EQ. 0) THEN
  1186. nbfus = 1
  1187. SEGINI SLSFUS
  1188. SLSFUS.CHAFUS(nbfus) = ia
  1189. SLSSOR.CHATYP(nbso) = cha8a
  1190. SLSSOR.CHANOM(nbso) = cha64a
  1191. SLSSOR.CHALIS(nbso) = SLSFUS
  1192. ELSE
  1193. SLSFUS = SLSSOR.CHALIS(nbso)
  1194. nbfus = SLSFUS.CHAFUS(/1) + 1
  1195. SEGADJ SLSFUS
  1196. SLSFUS.CHAFUS(nbfus) = ia
  1197. ENDIF
  1198. C-------Sortie d'une TABLE
  1199. ELSE
  1200. isea1 = 0
  1201. isea2 = 0
  1202. C---------On cherche une syntaxe de sortie
  1203. CALL MEDNML(2, 2, fname, cha64a, isca)
  1204. IF (isca .EQ. 0) THEN
  1205. cha64a = fname
  1206. ENDIF
  1207. CALL MEDNML(3, 3, fname, cha64b, iscb)
  1208. IF (iscb .EQ. 0) THEN
  1209. cha64b = fname
  1210. ENDIF
  1211. C---------On cherche une syntaxe de fusion
  1212. IF (nbso .EQ. 0) THEN
  1213. nbso = nbso + 1
  1214. IF (nbso .GT. nbsor) THEN
  1215. nbsor = nbsor + 20
  1216. SEGADJ SLSSOR
  1217. ENDIF
  1218. ELSE
  1219. CALL PLACE(SLSSOR.CHANOM, nbso, iamo, cha64a)
  1220. IF (iamo .EQ. 0) THEN
  1221. nbso = nbso + 1
  1222. IF (nbso .GT. nbsor) THEN
  1223. nbsor = nbsor + 20
  1224. SEGADJ SLSSOR
  1225. ENDIF
  1226. ELSE
  1227. cha8b = SLSSOR.CHATYP(iamo)
  1228. IF (cha8b .NE. 'TABLE') THEN
  1229. WRITE(IOIMP,*) ' ERREUR On voulait TABLE mais on a'
  1230. & ,cha8b
  1231. CALL ERREUR(21)
  1232. RETURN
  1233. ENDIF
  1234. nbso = iamo
  1235. isea1 = 1
  1236. ENDIF
  1237. ENDIF
  1238. C---------On rempli l'information
  1239. nbso1 = nbso
  1240. nbsor1 = nbsor
  1241.  
  1242. IF (isea1 .EQ. 0) THEN
  1243. nbsor = 1
  1244. SEGINI SLSSO1
  1245. nbfus = 1
  1246. SEGINI SLSFUS
  1247. SLSFUS.CHAFUS(nbfus) = ia
  1248. SLSSO1.CHATYP(nbsor) = cha8a
  1249. SLSSO1.CHANOM(nbsor) = cha64b
  1250. SLSSO1.CHALIS(nbsor) = SLSFUS
  1251. SLSSOR.CHATYP(nbso1) = 'TABLE'
  1252. SLSSOR.CHANOM(nbso1) = cha64a
  1253. SLSSOR.CHALIS(nbso1) = SLSSO1
  1254. ELSE
  1255. SLSSO1 = SLSSOR.CHALIS(nbso1)
  1256. nbsor = SLSSO1.CHALIS(/1)
  1257. CALL PLACE(SLSSO1.CHANOM, nbsor, iamo, cha64b)
  1258. IF (iamo .EQ. 0) THEN
  1259. nbsor = nbsor + 1
  1260. SEGADJ SLSSO1
  1261. ELSE
  1262. cha8b = SLSSO1.CHATYP(iamo)
  1263. IF (cha8b .NE. cha8a) THEN
  1264. WRITE(IOIMP,*) ' ERREUR cha8b different de cha8a'
  1265. WRITE(IOIMP,*) ' ', cha8a, cha8b
  1266. CALL ERREUR(21)
  1267. RETURN
  1268. ENDIF
  1269. nbsor = iamo
  1270. isea2 = 1
  1271. ENDIF
  1272.  
  1273. IF (isea2 .EQ. 0) THEN
  1274. nbfus = 1
  1275. SEGINI SLSFUS
  1276. SLSFUS.CHAFUS(nbfus) = ia
  1277. SLSSO1.CHATYP(nbsor) = cha8a
  1278. SLSSO1.CHANOM(nbsor) = cha64b
  1279. SLSSO1.CHALIS(nbsor) = SLSFUS
  1280. ELSE
  1281. SLSFUS = SLSSO1.CHALIS(nbsor)
  1282. nbfus = SLSFUS.CHAFUS(/1) + 1
  1283. SEGADJ SLSFUS
  1284. SLSFUS.CHAFUS(nbfus) = ia
  1285. ENDIF
  1286. ENDIF
  1287.  
  1288. nbso = nbso1
  1289. nbsor = nbsor1
  1290. ENDIF
  1291.  
  1292. ENDDO
  1293. SEGSUP LISPRO
  1294.  
  1295. C***********************************************************************
  1296. C Ecriture des champs
  1297. C***********************************************************************
  1298. DO ia=1,nbso
  1299. cha8a = SLSSOR.CHATYP(ia)
  1300. cha64a = SLSSOR.CHANOM(ia)
  1301. c WRITE(IOIMP,*) ia, ' nom ', cha64a, ' type ',cha8a
  1302. isor = 0
  1303.  
  1304. IF (cha8a .EQ. 'CHPOINT') THEN
  1305. SLSFUS = SLSSOR.CHALIS(ia)
  1306. CALL LMDCHP(fid, MTABLE, nbnoin, SLSCHA, SLSFUS, 1, isor)
  1307. IF (IERR.NE.0) RETURN
  1308. ELSEIF (cha8a .EQ. 'MCHAML') THEN
  1309. SLSFUS = SLSSOR.CHALIS(ia)
  1310. CALL LMDCHM(fid, MTABLE, SLSCHA, SLSFUS, 1, isor)
  1311. IF (IERR.NE.0) RETURN
  1312. ELSEIF (cha8a .EQ. 'TABLE') THEN
  1313. SLSSO1 = SLSSOR.CHALIS(ia)
  1314. CALL LMDTAB(fid, MTABLE, nbnoin, SLSCHA, SLSSO1, isor)
  1315. IF (IERR.NE.0) RETURN
  1316. ENDIF
  1317.  
  1318. CALL ECCTAB(MTABLE,'MOT',IVALIN,XVALIN,cha64a,LOGIN,IOBIN,
  1319. & cha8a,IVALRE,XVALRE,CHARRE,LOGRE,isor)
  1320.  
  1321. ENDDO
  1322.  
  1323. C***********************************************************************
  1324. C Ecriture de la TABLE Résultat
  1325. C***********************************************************************
  1326. 999 CONTINUE
  1327. SEGDES,MTABLE
  1328. CALL ECROBJ('TABLE ',MTABLE)
  1329.  
  1330. C***********************************************************************
  1331. C Fermeture du fichier .med
  1332. C***********************************************************************
  1333. CALL MFICLO(fid, cret)
  1334. IF(cret .NE. 0) THEN
  1335. moterr = 'mficlo'
  1336. interr(1) = cret
  1337. CALL ERREUR(873)
  1338. RETURN
  1339. ENDIF
  1340.  
  1341. C***********************************************************************
  1342. C Nettoyage
  1343. C***********************************************************************
  1344. IF (SLSCHA .GT. 0) SEGSUP,SLSCHA
  1345. IF (SLSSOR .GT. 0) SEGSUP,SLSSOR
  1346.  
  1347. END
  1348.  
  1349.  

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