Télécharger lirmed.eso

Retour à la liste

Numérotation des lignes :

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

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