Télécharger lirmed.eso

Retour à la liste

Numérotation des lignes :

  1. C LIRMED SOURCE CB215821 17/01/06 21:15:01 9273
  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 :
  10. C***********************************************************************
  11. C Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  12. C en cas de modification de ce sous-programme afin de faciliter
  13. C la maintenance !
  14. C***********************************************************************
  15. C APPELÉ PAR : opérateur LIRE (lirefi.eso)
  16. C***********************************************************************
  17. C ENTRÉES : Nom du fichier à lire
  18. C SORTIES : aucune
  19. C***********************************************************************
  20. C SYNTAXE (GIBIANE) :
  21. C
  22. C LIRE 'MED' 'fichier.med'
  23. C
  24. C
  25. C***********************************************************************
  26. subroutine lirmed
  27. implicit integer(i-n)
  28. implicit real*8(a-h,o-z)
  29.  
  30. C **********************************************************************
  31. C MODIFICATION CLEMENT BERTHINIER MED3.0
  32. C on met l'include spécifique du format MED
  33. C concaténation de med_parameter.hf77 et med.hf77
  34. C **********************************************************************
  35. -INC CCMED
  36. -INC CCOPTIO
  37. -INC SMELEME
  38. -INC SMCOORD
  39. -INC SMLMOTS
  40. -INC CCGEOME
  41. -INC SMTABLE
  42. -INC SMCHPOI
  43.  
  44.  
  45.  
  46. C **********************************************************************
  47. C Clement Ajout pour MED 3.0 DEBUT
  48. C **********************************************************************
  49. C Définition des entiers *4
  50. INTEGER*4 fid
  51. INTEGER*4 access
  52. INTEGER*4 cret
  53. INTEGER*4 sdim
  54. INTEGER*4 mdim
  55. INTEGER*4 naxis
  56.  
  57. INTEGER*4 mtype
  58. INTEGER*4 stype
  59. INTEGER*4 atype
  60. INTEGER*4 entype
  61. INTEGER*4 geotyp
  62. INTEGER*4 datype
  63. INTEGER*4 chgt
  64. INTEGER*4 tsf
  65.  
  66. INTEGER*4 numdt
  67. INTEGER*4 numit
  68. INTEGER*4 nstep
  69. INTEGER*4 swm
  70. INTEGER*4 fnum
  71. INTEGER*4 cmode
  72. INTEGER*4 n
  73. INTEGER*4 it
  74.  
  75.  
  76. C Chaines de Caractere de longueur MED_SNAME_SIZE=16
  77. CHARACTER*16 dtunit
  78.  
  79. segment saname
  80. character*16 aname(IDIM)
  81. endsegment
  82.  
  83. segment saunit
  84. character*16 aunit(IDIM)
  85. endsegment
  86.  
  87.  
  88. C Chaines de Caractere de longueur MED_NAME_SIZE=64
  89. CHARACTER*64 name
  90. CHARACTER*64 fam
  91.  
  92. C Chaines de Caractere de longueur MED_LNAME_SIZE=80
  93. CHARACTER*80 char80
  94.  
  95.  
  96. C Chaines de Caractere de longueur MED_COMMENT_SIZE
  97. CHARACTER*200 desc
  98.  
  99. C Segments
  100. segment maitot
  101. C Contiendra les MAILLAGES SIMPLES au sens de Cast3M
  102. integer ipomai(ntypel)
  103. integer inumli(ntypel)
  104.  
  105. C ntypel ==> Type d'élément au sens de Cast3M
  106. C ipomai ==> pointeur MAILLAGE SIMPLE
  107. C inumli ==> pointeur vers le tableau des numéros de famille de chaque éléments
  108. endsegment
  109.  
  110. segment numli8
  111. integer numlis(NBELEM)
  112. endsegment
  113.  
  114. segment Sfanoe
  115. C Contiendra les numéros des familles des noeuds
  116. integer nfanoe(nbpta)
  117. endsegment
  118.  
  119. segment Sfami
  120. C Segment contenant les informations sur les familles
  121. integer iFamNu(infam)
  122. integer pFamGr(infam)
  123. character*64 cFaNom(infam)
  124. integer pFaMai(infam)
  125.  
  126. C infam ==> Indice de la famille
  127. C iFamNu ==> Numéro de la famille
  128. C pFamGr ==> Pointeur vers le Segment sFamGr : nom des groupes dans la famille
  129. C cFaNom ==> Nom de la famille
  130. C pFaMai ==> Pointeur vers MELEME de la famille en question
  131. endsegment
  132.  
  133. segment sFamGr
  134. C Segment contenant les noms des groupes
  135. character*80 cFaGrNom(ngroup)
  136. endsegment
  137.  
  138.  
  139. segment SGrTot
  140. C Segment contenant les groupes de noms différents (Casse y compris)
  141. character*64 cGrNom(nGrDif)
  142.  
  143. C cGrNom ==> Nom des groupes différents
  144. endsegment
  145.  
  146. C ******************************************************************** C
  147. C Clement Ajout pour MED 3.0 FIN
  148. C ******************************************************************** C
  149.  
  150. character*8 cha8
  151. character*64 NOMMAA,cha64
  152. character*200 DESMAA
  153. logical ltelq
  154.  
  155.  
  156. segment iclame
  157. integer icla(320),itab(17)
  158. endsegment
  159.  
  160. segment icoor
  161. real*8 xcoo(isdim,nbpta)
  162. endsegment
  163.  
  164. C segment att
  165. C integer attr(INBATT)
  166. C integer attr2(INBATT)
  167. C character*200 attr3(INBATT)
  168. C endsegment
  169.  
  170. segment SINT4
  171. integer int4(ITAILL)
  172. endsegment
  173.  
  174. external long
  175.  
  176. CHARACTER*26 MINU,MAJU
  177. character*72 medres
  178. DATA MINU/'abcdefghijklmnopqrstuvwxyz'/
  179. DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  180.  
  181. C***********************************************************************
  182. C
  183. C Initialisation des segments de travail
  184. C
  185. C***********************************************************************
  186.  
  187. segini iclame
  188.  
  189. icla(1 )= 1
  190. icla(102)= 2
  191. icla(103)= 3
  192. icla(203)= 4
  193. icla(206)= 6
  194. icla(204)= 8
  195. icla(207)= 7
  196. icla(208)= 10
  197. icla(209)= 11
  198. icla(308)= 14
  199. icla(320)= 15
  200. icla(306)= 16
  201. icla(315)= 17
  202. icla(304)= 23
  203. icla(310)= 24
  204. icla(305)= 25
  205. icla(313)= 26
  206.  
  207. itab(1 ) = 1
  208. itab(2 ) = 102
  209. itab(3 ) = 103
  210. itab(4 ) = 203
  211. itab(5 ) = 206
  212. itab(6 ) = 204
  213. itab(7 ) = 208
  214. itab(8 ) = 308
  215. itab(9 ) = 320
  216. itab(10) = 306
  217. itab(11) = 315
  218. itab(12) = 304
  219. itab(13) = 310
  220. itab(14) = 305
  221. itab(15) = 313
  222. itab(16) = 207
  223. itab(17) = 209
  224.  
  225.  
  226. C***********************************************************************
  227. C
  228. C Debut de la lecture
  229. C
  230. C***********************************************************************
  231. ltelq=.TRUE.
  232. C nbref=0
  233. C nbsous=0
  234.  
  235. call lircha(medres,1,iretou)
  236. if(ierr.ne.0) then
  237. C Suppression des segments inutilises
  238. segsup iclame
  239. return
  240. endif
  241.  
  242. C write(ioimp,*)'Fichier en entree : ',medres
  243.  
  244. C SP : MLMOTS ????
  245. call lirobj('MLMOTS',mlmot1,0,iretou)
  246. if(iretou.ne.0) then
  247. call lirobj('MLMOTS',mlmot2,1,iretou)
  248. if(ierr.ne.0) then
  249. C Suppression des segments inutilises
  250. segsup iclame
  251. return
  252. endif
  253.  
  254. segact mlmot1,mlmot2
  255. if(mlmot1.mots(/2).ne.mlmot2.mots(/2)) then
  256. call erreur(19)
  257. C Suppression des segments inutilises
  258. segsup iclame
  259. return
  260. endif
  261. endif
  262.  
  263. C********************************************
  264. C Lecture dans le fichier .med
  265. C********************************************
  266. C
  267. iloh=long(medres)
  268. C********************************************
  269. C Ouverture d'un fichier MED 3.0
  270. C********************************************
  271. C Ancien Appel MED 2.3
  272. C call EFOUVR4(ifid,medres(1:iloh),0,ICRET)
  273.  
  274. C Nouvel Appel MED 3.0
  275. name = medres(1:iloh)
  276. access = MED_ACC_RDONLY
  277. cret = 0
  278. C fid = OUT
  279.  
  280. CALL mfiope (fid, name, access, cret)
  281. IF(cret.NE.0) THEN
  282. INTERR(1)=1
  283. MOTERR(1:40)=name(1:40)
  284. CALL ERREUR(424)
  285. RETURN
  286. ENDIF
  287.  
  288.  
  289. C***********************************************************************
  290. C Lecture du nombre de maillages dans un fichier MED 3.0
  291. C***********************************************************************
  292. call mmhnmh(fid,n,cret)
  293. IF(cret.NE.0) THEN
  294. WRITE(IOIMP,*) 'Erreur lecture Nbr Maillage '
  295. CALL ERREUR(21)
  296. RETURN
  297. C ELSE
  298. C WRITE(IOIMP,*) 'Lecture Nbr Maillage : OK'
  299. ENDIF
  300.  
  301. NBMAIL=n
  302.  
  303.  
  304. do i=1,NBMAIL
  305.  
  306. C***********************************************************************
  307. C Lecture du nombre d'axes du repère des coordonnées du maillage
  308. C***********************************************************************
  309. it = i
  310. C naxis = OUT
  311. CALL mmhnax(fid, it, naxis, cret)
  312.  
  313. IF(cret.NE.0) THEN
  314. WRITE(IOIMP,*) 'Erreur Lecture du nombre d''axe du maillage '
  315. CALL ERREUR(21)
  316. RETURN
  317. C ELSE
  318. C WRITE(IOIMP,*) 'Lecture du nombre d''axe du maillage : OK'
  319. ENDIF
  320.  
  321. IMDIM = naxis
  322.  
  323. C Changement de la dimension de l'espace en cas de necessité
  324. C J'utilise le GIBIANE pour le faire : "OPTI DIME IMDIM;"
  325. IF (IDIM.lt.IMDIM) THEN
  326. CALL ECRENT(IMDIM)
  327. CALL ECRCHA('DIME')
  328. CALL OPTION(1)
  329.  
  330. IF (IERR.NE.0) THEN
  331. WRITE(IOIMP,*)'Erreur de changement de dimension'
  332. CALL ERREUR(219)
  333. ENDIF
  334.  
  335. WRITE(IOIMP,*) ' '
  336. WRITE(IOIMP,*) 'Passage en DIMEnsion ',IMDIM
  337. WRITE(IOIMP,*) ' '
  338. ENDIF
  339.  
  340.  
  341. C Initialisation des segments pour les Unités des Axes (Non renseignés dans notre cas)
  342. C write(IOIMP,*)'IDIM=',IDIM
  343. segini saname
  344. segini saunit
  345.  
  346.  
  347. C***********************************************************************
  348. C Lecture des informations d'un maillage MED 3.0
  349. C***********************************************************************
  350. C Ancien Appel MED 2.3
  351. C call EFMAAI4(IFID,i,NOMMAA,ISDIM,ITYPEM,DESMAA,ICRET)
  352.  
  353. C Nouvel Appel MED 3.0
  354. it = i
  355. C name = OUT
  356. C sdim = OUT
  357. C mdim = OUT
  358. C mtype = OUT
  359. C desc = OUT
  360. C dtunit = OUT
  361. C stype = OUT
  362. C nstep = OUT
  363. C atype = OUT
  364. C aname = OUT
  365. C aunit = OUT
  366. CALL mmhmii (fid, it, name, sdim, mdim, mtype, desc, dtunit,
  367. & stype, nstep, atype, aname, aunit, cret)
  368.  
  369.  
  370. IF(cret.NE.0) THEN
  371. WRITE(IOIMP,*) 'Erreur Lecture Info Maillage '
  372. CALL ERREUR(21)
  373. RETURN
  374. C ELSE
  375. C WRITE(IOIMP,*) 'Lecture Info Maillage : OK'
  376. ENDIF
  377.  
  378. C write(IOIMP,*)' '
  379. C write(IOIMP,*)'fid : ',fid
  380. C write(IOIMP,*)'it : ',it
  381. C write(IOIMP,*)'name "',name,'"'
  382. C write(IOIMP,*)'sdim : ',sdim
  383. C write(IOIMP,*)'mdim : ',mdim
  384. C write(IOIMP,*)'mtype : ',mtype
  385. C write(IOIMP,*)'desc "',desc,'"'
  386. C write(IOIMP,*)'dtunit "',dtunit,'"'
  387. C write(IOIMP,*)'stype : ',stype
  388. C write(IOIMP,*)'nstep : ',nstep
  389. C write(IOIMP,*)'atype : ',atype
  390. C do idd=1,idim
  391. C write(IOIMP,*)' aname(',idd,')="',aname(idd),'"'
  392. C write(IOIMP,*)' aunit(',idd,')="',aunit(idd),'"'
  393. C enddo
  394.  
  395. NOMMAA = name
  396. ISDIM = sdim
  397. ITYPEM = mtype
  398. DESMAA = desc
  399.  
  400.  
  401. C Write(IOIMP,*)' Maillage numero',i,' de nom :',NOMMAA(1:8)
  402.  
  403. C Suppression des segments inutilises
  404. segsup saname
  405. segsup saunit
  406. enddo
  407.  
  408.  
  409. C***********************************************************************
  410. C Lecture du nombre d'entités (Noeuds ici) dans un maillage MED 3.0
  411. C***********************************************************************
  412. C Ancien Appel MED 2.3
  413. C call EFNEMA4(IFID,NOMMAA,0,3,0,0,nbpta,ICRET)
  414.  
  415. C Nouvel Appel MED 3.0
  416. name = NOMMAA
  417. numdt = MED_NO_DT
  418. numit = MED_NO_IT
  419. entype = MED_NODE
  420. geotyp = 0
  421. C geotyp = quelconque d'après la doc html
  422. datype = MED_COORDINATE
  423. cmode = MED_NODAL
  424. chgt = MED_FALSE
  425. tsf = MED_FALSE
  426. C n = OUT
  427. CALL mmhnme (fid, name, numdt, numit, entype, geotyp, datype,
  428. & cmode, chgt, tsf, n, cret)
  429. nbpta = n
  430.  
  431. C write(IOIMP,*)'DEBUT INFOS'
  432. C write(IOIMP,*)'fid : ',fid
  433. C write(IOIMP,*)'name "',name,'"'
  434. C write(IOIMP,*)'numdt : ',numdt
  435. C write(IOIMP,*)'numit : ',numit
  436. C write(IOIMP,*)'entype : ',entype
  437. C write(IOIMP,*)'geotyp : ',geotyp
  438. C write(IOIMP,*)'datype : ',datype
  439. C write(IOIMP,*)'cmode : ',cmode
  440. C write(IOIMP,*)'chgt : ',chgt
  441. C write(IOIMP,*)'tsf : ',tsf
  442. C write(IOIMP,*)'n : ',n
  443. C write(IOIMP,*)'nbpta : ',nbpta
  444. C write(IOIMP,*)'FIN INFOS'
  445.  
  446. IF(cret.NE.0) THEN
  447. WRITE(IOIMP,*) 'Erreur Lecture des entites dans un maillage '
  448. CALL ERREUR(21)
  449. RETURN
  450. C ELSE
  451. C WRITE(IOIMP,*) 'Lecture des entites dans un maillage : OK'
  452. ENDIF
  453.  
  454. C write(IOIMP,*)'isdim : ',isdim
  455. segini icoor
  456.  
  457.  
  458. C***********************************************************************
  459. C Lecture des coordonnées des noeuds MED 3.0
  460. C***********************************************************************
  461. C Ancien Appel MED 2.3
  462. C call EFCOOL4(IFID, NOMMAA, ISDIM, icoor.xcoo(1,1), 0, 0, 0, 0, IREPER,
  463. C & COMP, UNIT, ICRET, 0, 0)
  464.  
  465. C Nouvel Appel MED 3.0
  466. name = NOMMAA
  467. numdt = MED_NO_DT
  468. numit = MED_NO_IT
  469. swm = MED_FULL_INTERLACE
  470. C icoor.xcoo = OUT
  471.  
  472. C write(IOIMP,*)' '
  473. C write(IOIMP,*)'DEBUT INFOS'
  474. C write(IOIMP,*)'name : ',name,':'
  475. C write(IOIMP,*)'numdt : ',numdt
  476. C write(IOIMP,*)'numit : ',numit
  477. C write(IOIMP,*)'swm : ',swm
  478. C write(IOIMP,*)'FIN INFOS'
  479. C write(IOIMP,*)' '
  480. CALL mmhcor (fid, name, numdt, numit, swm, icoor.xcoo, cret)
  481.  
  482. C DO IDD=1,icoor.xcoo(/2)
  483. C Affichage des coordonnées des noeuds
  484. C write(ioimp,*) 'icoor.xcoo(1,',IDD,') = ',icoor.xcoo(1,IDD),
  485. C & 'icoor.xcoo(2,',IDD,') = ',icoor.xcoo(2,IDD)
  486. C ENDDO
  487.  
  488. IF(cret.NE.0) THEN
  489. WRITE(IOIMP,*) 'Erreur Lecture des coordonnees des noeuds '
  490. CALL ERREUR(21)
  491. RETURN
  492. C ELSE
  493. C WRITE(IOIMP,*) 'Lecture des coordonnees des noeuds : OK'
  494. ENDIF
  495.  
  496. C Les coordonnées des noeuds lus sont placées dans le tableau XCOOR
  497. C du segments MCOORD (SMCOORD.INC)
  498.  
  499. nbnoin= xcoor(/1)/(idim+1)
  500. ndecco= xcoor(/1)
  501. NBPTS=nbpta + nbnoin
  502. C write (IOIMP,*)'nbpta=',nbpta
  503. C write (IOIMP,*)'nbnoin=',nbnoin
  504. C write (IOIMP,*)'ndecco=',ndecco
  505.  
  506. C Mise à jour du segment MCOORD
  507. segadj mcoord
  508.  
  509. do nbnoeu=1,nbpta
  510. do indice=1,ISDIM
  511. xcoor(ndecco+indice+(nbnoeu-1)*(IDIM+1))=
  512. & icoor.xcoo(indice,nbnoeu)
  513. enddo
  514. enddo
  515.  
  516. C Suppression du segment icoor
  517. segsup icoor
  518.  
  519.  
  520. ntypel = ITAB(/1)
  521. segini maitot
  522.  
  523.  
  524. C***********************************************************************
  525. C Lecture des numéros de famille des noeuds pour générer les POI1
  526. C***********************************************************************
  527. segini Sfanoe
  528.  
  529. nbelem=nbpta
  530. segini numli8
  531.  
  532. C Ancien Appel MED 2.3
  533. C CALL EFFAML4(IFID,NOMMAA,numli8.numlis(1),nbpta,3,0,
  534. C & ICRET,numli8.numlis(1))
  535.  
  536. C Nouvel Appel MED 3.0
  537. name = NOMMAA
  538. numdt = MED_NO_DT
  539. numit = MED_NO_IT
  540. entype = MED_NODE
  541. geotyp = 0
  542. C numli8.numlis = OUT
  543. itaill =numli8.numlis(/1)
  544. SEGINI,SINT4
  545.  
  546. CALL mhfnr4 (fid, name, numdt, numit, entype, geotyp,
  547. & numli8.numlis, SINT4.int4, cret, itaill)
  548.  
  549. SEGSUP,SINT4
  550. IF(cret.GT.0) THEN
  551. WRITE(IOIMP,*)'Erreur Lecture des numeros de famille de noeuds'
  552. CALL ERREUR(21)
  553. RETURN
  554. C ELSE
  555. C WRITE(IOIMP,*) 'Lecture des numeros de famille de noeuds : OK'
  556. ENDIF
  557.  
  558. C write(ioimp,*) 'numli8.numlis(/1)= ',numli8.numlis(/1)
  559. C DO ind_i=1,numli8.numlis(/1)
  560. C Affichage du contenu de numli8.numlis
  561. C write(ioimp,*)' numli8.numlis(',ind_i,')= ',
  562. C & numli8.numlis(ind_i)
  563. C ENDDO
  564.  
  565.  
  566.  
  567. C Création du MAILLAGE SIMPLE de POI1
  568. NBNN = 1
  569. NBELEM = nbpta
  570. NBSOUS = 0
  571. NBREF = 0
  572. segini ipt1
  573. ipt1.ITYPEL=1
  574. do indel=1,NBELEM
  575. ipt1.ICOLOR(indel)=idcoul
  576.  
  577. C La connectivité lue est décalée si des noeuds existaient avant
  578. ipt1.NUM(NBNN,indel)=indel+nbnoin
  579. enddo
  580.  
  581. nbType=1
  582.  
  583. C Sauvegarde du pointeur vers le MELEME simple
  584. maitot.ipomai(nbType)=ipt1
  585.  
  586. C Sauvegarde du pointeur vers le tableau des numéros de famille de chaque noeud de ce MAILLAGE SIMPLE de POI1
  587. maitot.inumli(nbType)=numli8
  588.  
  589.  
  590.  
  591. DO ITYPEM=1,ITAB(/1)
  592. C Boucle sur tous les types d'éléments autre que POI1 (déjà traités)
  593.  
  594. C***********************************************************************
  595. C Lecture du nombre d'entités (Eléments ici) en balayant tous les
  596. C MAILLAGES SIMPLES d'un maillage MED 3.0
  597. C***********************************************************************
  598. C Ancien Appel MED 2.3
  599. C call EFNEMA4(IFID,NOMMAA,1,0,ITAB(ITYPEM),0,n,ICRET)
  600.  
  601. C Nouvel Appel MED 3.0
  602. name = NOMMAA
  603. numdt = MED_NO_DT
  604. numit = MED_NO_IT
  605. entype = MED_CELL
  606. geotyp = ITAB(ITYPEM)
  607. datype = MED_CONNECTIVITY
  608. cmode = MED_NODAL
  609. chgt = MED_FALSE
  610. tsf = MED_FALSE
  611. C n = OUT
  612. CALL mmhnme (fid, name, numdt, numit, entype, geotyp, datype,
  613. & cmode, chgt, tsf, n, cret)
  614.  
  615. IF(cret.NE.0) THEN
  616. WRITE(IOIMP,*) 'Erreur Lecture Nbr elements dans un maillage '
  617. CALL ERREUR(21)
  618. RETURN
  619. C ELSE
  620. C WRITE(IOIMP,*) 'Lecture Nbr elements dans un maillage : OK'
  621. C write(ioimp,*) 'n = ',n
  622. ENDIF
  623.  
  624. if(n.ne.0) then
  625. nbType=nbType+1
  626.  
  627. NBNN=NBNNE(icla(itab(itypem)))
  628. NBELEM=n
  629. NBSOUS =0
  630. NBREF =0
  631. segini ipt1
  632.  
  633. ipt1.ITYPEL=icla(itab(itypem))
  634. do indel=1,NBELEM
  635. ipt1.ICOLOR(indel)=idcoul
  636. enddo
  637.  
  638.  
  639. C write(ioimp,*)'Dimensions de NUM :'
  640. C write(ioimp,*) 'NUM(/1)= ',NUM(/1)
  641. C write(ioimp,*) 'NUM(/2)= ',NUM(/2)
  642. C write(IOIMP,*) 'NOMMAA = "', NOMMAA,'"'
  643. C write(IOIMP,*) 'ipt1 = ' , ipt1
  644. C write(IOIMP,*) 'ITYPEM = ' , ITYPEM
  645. C write(IOIMP,*) 'NBELEM = ' , NBELEM
  646. C write(IOIMP,*) 'NBNN = ' , NBNN
  647.  
  648.  
  649. C***********************************************************************
  650. C Lecture des connectivités des éléments
  651. C***********************************************************************
  652. C Ancien Appel MED 2.3
  653. C CALL EFCONL4(IFID,NOMMAA,ISDIM,num,0,0,0,0,ITAB(ITYPEM),0,
  654. C & ICRET,num,num(/1)*num(/2),0,0)
  655.  
  656. C Nouvel Appel MED 3.0
  657. name = NOMMAA
  658. numdt = MED_NO_DT
  659. numit = MED_NO_IT
  660. entype = MED_CELL
  661. geotyp = ITAB(ITYPEM)
  662. cmode = MED_NODAL
  663. swm = MED_FULL_INTERLACE
  664. C con = OUT
  665.  
  666. C write(IOIMP,*) 'numdt = ' , numdt
  667. C write(IOIMP,*) 'numit = ' , numit
  668. C write(IOIMP,*) 'entype = ' , entype
  669. C write(IOIMP,*) 'geotyp = ' , geotyp
  670. C write(IOIMP,*) 'cmode = ' , cmode
  671. C write(IOIMP,*) 'swm = ' , swm
  672.  
  673. call mhcyr4 (fid, name, numdt, numit, entype, geotyp,
  674. & cmode, swm, ipt1.NUM, cret,
  675. & ipt1.NUM(/1), ipt1.NUM(/2))
  676.  
  677. IF(cret.NE.0) THEN
  678. WRITE(IOIMP,*) 'Erreur lecture connectivite elementaire '
  679. CALL ERREUR(21)
  680. RETURN
  681. C ELSE
  682. C WRITE(IOIMP,*) 'Lecture connectivite elementaire : OK'
  683. C DO indicei=1,ipt1.NUM(/1)
  684. C DO indicej=1,ipt1.NUM(/2)
  685. C Affichage des connectivités
  686. C write(ioimp,*) 'ipt1.NUM(',indicei,',',indicej,')= ',
  687. C & ipt1.NUM(indicei,indicej)
  688. C ENDDO
  689. C ENDDO
  690. ENDIF
  691.  
  692. C La connectivité lue est décalée si des noeuds existaient avant
  693. if(nbnoin.ne.0) then
  694. do iou=1,NBNN
  695. do jou=1,NBELEM
  696. ipt1.NUM(iou,jou)=ipt1.NUM(iou,jou)+nbnoin
  697. enddo
  698. enddo
  699. endif
  700.  
  701. C Passage de la connectivité MED 3.0 à Cast3M
  702. call medtra(ipt1,2)
  703.  
  704.  
  705. C Sauvegarde du pointeur vers le MELEME simple
  706. maitot.ipomai(nbType)=ipt1
  707.  
  708. C***********************************************************************
  709. C Lecture des numéros de famille des types d'éléments : type ITAB(ITYPEM)
  710. C***********************************************************************
  711. C Ancien Appel MED 2.3
  712. C CALL EFFAML4(IFID,NOMMAA,numli8.numlis(1),n,0,
  713. C & ITAB(ITYPEM), ICRET, numli8.numlis(1))
  714.  
  715. C Nouvel Appel MED 3.0
  716. segini numli8
  717. name = NOMMAA
  718. numdt = MED_NO_DT
  719. numit = MED_NO_IT
  720. entype = MED_CELL
  721. geotyp = ITAB(ITYPEM)
  722. itaill = numli8.numlis(/1)
  723. C numli8.numlis = OUT
  724. SEGINI,SINT4
  725.  
  726. CALL mhfnr4 (fid, name, numdt, numit, entype, geotyp,
  727. & numli8.numlis, SINT4.int4, cret, itaill)
  728.  
  729. SEGSUP,SINT4
  730. IF(cret.NE.0) THEN
  731. WRITE(IOIMP,*) 'Erreur Lecture des numeros de famille de'
  732. WRITE(IOIMP,*) ' Type d''element'
  733. CALL ERREUR(21)
  734. RETURN
  735. C ELSE
  736. C WRITE(IOIMP,*) 'Lecture des numeros de famille de'
  737. C WRITE(IOIMP,*) ' Type d''element : OK'
  738. ENDIF
  739.  
  740. C write(ioimp,*) 'numli8.numlis(/1)= ',numli8.numlis(/1)
  741. C DO ind_i=1,numli8.numlis(/1)
  742. C Affichage du contenu de numli8.numlis
  743. C write(ioimp,*)' numli8.numlis(',ind_i,')= ',
  744. C & numli8.numlis(ind_i)
  745. C ENDDO
  746.  
  747.  
  748.  
  749. C Sauvegarde du pointeur vers le tableau des numéros de famille de chaque éléments de ce MAILLAGE SIMPLE
  750. maitot.inumli(nbType)=numli8
  751. endif
  752. ENDDO
  753.  
  754.  
  755. C Le segment contenant toutes les infos des maillages est ajusté
  756. ntypel = nbType
  757. segadj maitot
  758.  
  759.  
  760.  
  761. C***********************************************************************
  762. C Création d'un MAILLAGE COMPLEXE contenant tous les MELEME SIMPLES
  763. C***********************************************************************
  764. NBREF=0
  765. NBSOUS=nbType-1
  766. NBELEM=0
  767. NBNN=0
  768. segini ipt1
  769.  
  770. DO indsou=1,nbType-1
  771. ipt2 = maitot.ipomai(indsou+1)
  772. ipt1.lisous(indsou) = ipt2
  773. C WRITE(IOIMP,*)'Pointeur MELEME simples ',NOMS(ipt2.ITYPEL),' :',
  774. C & ipt2
  775. C WRITE(IOIMP,*)'ITYPEL : ',ipt2.ITYPEL
  776. C WRITE(IOIMP,*)'NBNN : ',ipt2.NUM(/1)
  777. C WRITE(IOIMP,*)'NBELEM : ',ipt2.NUM(/2)
  778. ENDDO
  779.  
  780. segdes ipt1
  781.  
  782.  
  783. C Creation de la TABLE de resultats
  784. M=0
  785. SEGINI,MTABLE
  786.  
  787.  
  788. C Ecriture dans la table du MAILLAGE complet des FAMILLES => Partition
  789. CALL ECCTAB(MTABLE,'MOT ',0 ,0.d0,NOMMAA,.FALSE.,0 ,
  790. & 'MAILLAGE',0 ,0.d0,' ',.FALSE.,ipt1)
  791.  
  792. C cha8=NOMMAA(1:8)
  793. C Passage en majuscule du nom du maillage dans Cast3M sur 8 Caractères
  794. C do iaux=1,LEN(cha8)
  795. C IRAL=INDEX(MINU,cha8(IAUX:IAUX))
  796. C IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL)
  797. C enddo
  798. C La Famille complete est nommée dans Cast3M
  799. C call nomobj('MAILLAGE',cha8 ,ipt1)
  800.  
  801.  
  802.  
  803. C***********************************************************************
  804. C Lecture du nombre de famille dans un maillage
  805. C***********************************************************************
  806. C Ancien Appel MED 2.3
  807. C CALL EFNFAM4(IFID,NOMMAA,INFAM,ICRET)
  808.  
  809. C Nouvel Appel MED 3.0
  810. name = NOMMAA
  811. C n = OUT
  812.  
  813. call mfanfa (fid, name, n, cret)
  814.  
  815. IF(cret.NE.0) THEN
  816. WRITE(IOIMP,*) 'Erreur Lecture du nombre de famille'
  817. CALL ERREUR(21)
  818. RETURN
  819. C ELSE
  820. C WRITE(IOIMP,*) 'Lecture du nombre de famille : OK'
  821. C WRITE(IOIMP,*) 'Nombre de familles dans ',NOMMAA(1:8),' = ',n
  822. C WRITE(IOIMP,*) ' '
  823. ENDIF
  824.  
  825.  
  826. INFAM = n
  827. segini Sfami
  828.  
  829. nGrDif = 10
  830. segini SGrTot
  831.  
  832. nCompG = 0
  833.  
  834. DO iFam=1,INFAM
  835. C**********************************************************************
  836. C Lecture du nombre de groupe dans une famille
  837. C**********************************************************************
  838. C Ancien Appel MED 2.3
  839. C CALL EFNGRO4(IFID,NOMMAA,iFam,ngroup,ICRET)
  840.  
  841. C Nouvel Appel MED 3.0
  842. name = NOMMAA
  843. it = iFam
  844. C n = OUT
  845.  
  846. call mfanfg (fid, name, it, n, cret)
  847. ngroup = n
  848.  
  849. IF(cret.NE.0) THEN
  850. WRITE(IOIMP,*) ' Erreur Lecture du nombre de groupe'
  851. CALL ERREUR(21)
  852. RETURN
  853. C ELSE
  854. C WRITE(IOIMP,*) ' Lecture du nombre de groupe : OK'
  855. C WRITE(IOIMP,*) ' Famille :',iFam,' Nbr Groupe :',n
  856. ENDIF
  857.  
  858. segini sFamGr
  859.  
  860.  
  861.  
  862. C**********************************************************************
  863. C Lecture du nombre d'attribut dans une famille
  864. C Valable uniquement dans MED 2.2 et 2.3
  865. C Retiré dans MED 3.0
  866. C**********************************************************************
  867. C Ancien Appel MED 2.3
  868. C CALL EFNATT4(IFID,NOMMAA,iFam,INBATT,ICRET)
  869.  
  870. C write(6,*) ' inbatt ' , inbatt
  871. C segini att
  872. C write(6,*) ' appel effami inbatt ngroup ' ,inbatt,ngroup
  873.  
  874. C**********************************************************************
  875. C Lecture des informations sur une famille
  876. C**********************************************************************
  877. C Ancien Appel MED 2.3
  878. C CALL EFFAMI4(IFID,NOMMAA,iFam,fam,fnum,attr,attr2,
  879. C & attr3,INBATT,sFamGr.cFaGrNom,ngroup,ICRET,attr,attr2)
  880.  
  881. C Nouvel Appel MED 3.0
  882. name = NOMMAA
  883. ind = iFam
  884. C fam = OUT
  885. C fnum = OUT
  886. C sFamGr.cFaGrNom = OUT
  887. call mfafai (fid, name, ind, fam, fnum, sFamGr.cFaGrNom, cret)
  888.  
  889. IF(cret.NE.0) THEN
  890. WRITE(IOIMP,*) ' Erreur Lecture informations famille'
  891. CALL ERREUR(21)
  892. RETURN
  893. C ELSE
  894. C WRITE(IOIMP,*) ' Lecture informations sur une famille : OK'
  895. C DO INOMGR=1,ngroup
  896. C WRITE(IOIMP,*) ' "', sFamGr.cFaGrNom(INOMGR),'"'
  897. C ENDDO
  898. ENDIF
  899.  
  900. C WRITE(IOIMP,*) 'name : "',NOMMAA,'"'
  901. C WRITE(IOIMP,*) 'it : ',it
  902. C WRITE(IOIMP,*) 'n : ',n
  903. C WRITE(IOIMP,*) 'fam : "',fam,'"'
  904. C WRITE(IOIMP,*) 'fnum : ',fnum
  905.  
  906. C DO indice=1,n
  907. C WRITE(IOIMP,*) 'sFamGr.cFaGrNom(',indice,') "',
  908. C & sFamGr.cFaGrNom(indice),'"'
  909. C ENDDO
  910.  
  911. C segsup att
  912.  
  913. Sfami.iFamNu(iFam) = fnum
  914. Sfami.pFamGr(iFam) = sFamGr
  915. Sfami.cFaNom(iFam) = fam
  916.  
  917.  
  918. C Construction à la volée de la liste des groupes différents
  919. IF (ngroup.GT.0) THEN
  920. C Cas ou le nombre de groupe n'est pas nul
  921.  
  922. IF (nCompG.EQ.0) THEN
  923. C Cas où la liste est vierge ==> Ajout de tous les noms
  924.  
  925. nCompG = nCompG + ngroup
  926.  
  927. C Ajustement intermédiaire (éventuel) du segment SGrTot
  928. IF (nCompG.GT.nGrDif) THEN
  929. nGrDif = nGrDif * 2
  930. segadj SGrTot
  931. ENDIF
  932.  
  933. DO IGROUP=1,ngroup
  934. SGrTot.cGrNom(IGROUP)=sFamGr.cFaGrNom(IGROUP)
  935. ENDDO
  936.  
  937. ELSE
  938. C Cas où des noms de groupes existent déjà ==> Comparaison aux noms existants
  939. DO IGROUP=1,ngroup
  940. IVERIF=0
  941. DO IGEXIS=1,nCompG
  942. IF(sFamGr.cFaGrNom(IGROUP).EQ.SGrTot.cGrNom(IGEXIS))THEN
  943. IVERIF=1
  944. ENDIF
  945. ENDDO
  946.  
  947. IF(IVERIF.EQ.0) THEN
  948. C Ajout du groupe s'il n'existe pas déjà
  949.  
  950. nCompG = nCompG + 1
  951.  
  952. C Ajustement intermédiaire (éventuel) du segment SGrTot
  953. IF (nCompG.GT.nGrDif) THEN
  954. nGrDif = nGrDif * 2
  955. segadj SGrTot
  956. ENDIF
  957.  
  958. SGrTot.cGrNom(nCompG)=sFamGr.cFaGrNom(IGROUP)
  959.  
  960. ENDIF
  961. ENDDO
  962. ENDIF
  963. ENDIF
  964.  
  965. ENDDO
  966.  
  967. C Ajustement final (éventuel) du segment SGrTot
  968. IF (nCompG.NE.nGrDif) THEN
  969. nGrDif = nCompG
  970. segadj SGrTot
  971. ENDIF
  972.  
  973. C Ménage dans les segments inutiles
  974. segsup iclame
  975.  
  976.  
  977. C***********************************************************************
  978. C Reconstitution des dépendances des maillages dans Cast3M
  979. C***********************************************************************
  980. C
  981. C creation des maillages des familles (POI1 compris)
  982. C
  983. nbref=0
  984. nbsous=0
  985. ipt3=0
  986.  
  987. do 104 iFam=1,infam
  988. C Boucle sur les familles lues
  989.  
  990. inufam=Sfami.iFamNu(iFam)
  991. C write(6,*) 'iFam =',iFam,'cFaNom = "',Sfami.cFaNom(iFam),'"',
  992. C & 'inufam = ',inufam
  993.  
  994. ipt3=0
  995. do iType=1,nbType
  996. C Boucle sur les types d'éléments
  997.  
  998. C Chargement du numéro de famille de la iFam ième famille
  999. numli8=maitot.inumli(iType)
  1000.  
  1001. nbelem=0
  1002. do iElem=1,numli8.numlis(/1)
  1003. C Calcule le nombre d'élément du type iType appartenant à la famille iFam
  1004. if(numli8.numlis(iElem).eq.inufam) THEN
  1005. nbelem=nbelem+1
  1006. endif
  1007. enddo
  1008.  
  1009.  
  1010. if(nbelem.gt.0) then
  1011. C Cas où un maillage d'éléments de type iType est a créer pour la famille iFam
  1012.  
  1013. C Chargement du maillage complet du type d'élément iType
  1014. ipt1=maitot.ipomai(iType)
  1015. nbnn=ipt1.num(/1)
  1016.  
  1017. C Création du nouveau maillage composé de la partition des éléments de ipt1 appartenant à la famille iFam
  1018. segini ipt2
  1019. iel=0
  1020. ipt2.itypel=ipt1.itypel
  1021. do iElem=1,numli8.numlis(/1)
  1022. if(numli8.numlis(iElem).eq.inufam) then
  1023. iel=iel+1
  1024. do iConn=1,nbnn
  1025. ipt2.num(iConn,iel)=ipt1.num(iConn,iElem)
  1026. enddo
  1027.  
  1028. ipt2.icolor(iel)=idcoul
  1029. endif
  1030. enddo
  1031.  
  1032. C Création du MELEME COMPLEXE s'il y a lieu
  1033. if(ipt3.eq.0) then
  1034. C write(6,*) ' Maillage initial:',ipt2
  1035. ipt3=ipt2
  1036.  
  1037. else
  1038. C write(6,*) ' appel fuse 1 ipt3,ipt2',ipt3,ipt2
  1039.  
  1040. C Fusion des maillages ipt3 et ipt2 dans ipt4
  1041. call fuse(ipt3,ipt2,ipt4,ltelq)
  1042.  
  1043. ipt3=ipt4
  1044. endif
  1045. endif
  1046. enddo
  1047.  
  1048. Sfami.pFaMai(iFam)=ipt3
  1049.  
  1050. 104 continue
  1051.  
  1052. C
  1053. C creation des maillages des groupes : OBJETS NOMMES DANS CAST3M
  1054. C
  1055.  
  1056. do IGROUP=1,nGrDif
  1057. char80=SGrTot.cGrNom(IGROUP)
  1058. ipt3=0
  1059.  
  1060. do 115 iFam=1,infam
  1061. sFamGr=Sfami.pFamGr(iFam)
  1062.  
  1063. do iNomGr=1,sFamGr.cFaGrNom(/2)
  1064. if(char80.eq.sFamGr.cFaGrNom(iNomGr)) then
  1065. if(ipt3.eq.0)then
  1066. ipt3=Sfami.pFaMai(iFam)
  1067.  
  1068. else
  1069. ipt2=Sfami.pFaMai(iFam)
  1070. C Fusion des maillages ipt3 et ipt2 dans ipt4
  1071. call fuse(ipt3,ipt2,ipt4,ltelq)
  1072.  
  1073. ipt3=ipt4
  1074. endif
  1075. go to 115
  1076. endif
  1077. enddo
  1078. 115 continue
  1079.  
  1080.  
  1081. C Ecriture dans la table du TYPE IMO(2:9)
  1082. CALL ECCTAB(MTABLE,'MOT ',0 ,0.d0,char80,.FALSE.,0 ,
  1083. & 'MAILLAGE',0 ,0.d0,' ',.FALSE.,ipt3)
  1084.  
  1085.  
  1086. C cha8=char80(1:8)
  1087.  
  1088. C do iaux=1,LEN(cha8)
  1089. C Passage du nom en MAJUSCULE
  1090. C IRAL=INDEX(MINU,cha8(IAUX:IAUX))
  1091. C IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL)
  1092. C enddo
  1093.  
  1094. C Le Groupe est nommé dans Cast3M
  1095. C call nomobj('MAILLAGE',cha8,ipt3)
  1096. enddo
  1097.  
  1098.  
  1099. C***********************************************************************
  1100. C Ménage dans les SEGMENTS
  1101. C***********************************************************************
  1102. if(mlmot1.ne.0) then
  1103. segdes mlmot1,mlmot2
  1104. endif
  1105.  
  1106. segsup maitot
  1107.  
  1108. do iou=1,infam
  1109. sFamGr=Sfami.pFamGr(iou)
  1110. segsup sFamGr
  1111.  
  1112. ipt1=Sfami.pFaMai(iou)
  1113. if(ipt1.GT.0) THEN
  1114. segdes ipt1
  1115. ENDIF
  1116. enddo
  1117. segsup Sfami
  1118. segsup SGrTot
  1119. segsup Sfanoe
  1120. segsup numli8
  1121.  
  1122.  
  1123. C***********************************************************************
  1124. C Ecriture de la TABLE Résultat
  1125. C***********************************************************************
  1126. SEGDES,MTABLE
  1127. CALL ECROBJ('TABLE ',MTABLE)
  1128.  
  1129.  
  1130. C***********************************************************************
  1131. C Lecture des champs par points
  1132. C***********************************************************************
  1133. C write(6,*) ' appel a medrch '
  1134. C call medrch(ifid,mlmot1,mlmot2,nbnoin,NOMMAA,nbpta,icret)
  1135.  
  1136.  
  1137.  
  1138. C************************************
  1139. C Fermeture du fichier .med
  1140. C************************************
  1141. C Ancien Appel MED 2.3
  1142. C call efferm4(ifid,icret)
  1143.  
  1144. C Nouvel Appel MED 3.0
  1145. CALL mficlo (fid, cret)
  1146.  
  1147. IF(cret.NE.0) THEN
  1148. WRITE(IOIMP,*) ' Erreur Fermeture du fichier'
  1149. CALL ERREUR(21)
  1150. RETURN
  1151. C ELSE
  1152. C WRITE(IOIMP,*) ' Fermeture du fichier : OK'
  1153. ENDIF
  1154.  
  1155.  
  1156. RETURN
  1157. END
  1158.  
  1159.  
  1160.  

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