Télécharger sormed.eso

Retour à la liste

Numérotation des lignes :

  1. C SORMED SOURCE CB215821 19/05/21 21:15:19 10221
  2. C***********************************************************************
  3. C NOM : sormed.eso
  4. C DESCRIPTION : Sortie d'un maillage au FORMAT .med
  5. C***********************************************************************
  6. C HISTORIQUE : 21/12/2010 : CHAT : creation de la subroutine
  7. C HISTORIQUE : 7/06/2012 : JCARDO : l'argument MOT1 devient optionnel
  8. C + ajout de l'extension .med
  9. C HISTORIQUE : 04/11/2013 : BERTHINC : PASSAGE AU FORMAT 3.0 DE MED
  10. C HISTORIQUE : 16/10/2017 : RPAREDES : SORTIE CHPOINT,MCHAML,PASAPAS
  11. C HISTORIQUE : 09/10/2018 : BERTHINC : CALL ERREUR au lieu de WRITE
  12. C TAILLES parametriqeus et pas fixes
  13. C HISTORIQUE : 28/11/2018 : JCARDO : remplacement TMLCHA8 par TMLNOMS
  14. C + noms groupes en MED_NAME_SIZE
  15. C HISTORIQUE :
  16. C***********************************************************************
  17. C Priere de PRENDRE LE TEMPS DE COMPLeTER LES COMMENTAIRES
  18. C en cas de modification de ce sous-programme afin de faciliter
  19. C la maintenance !
  20. C***********************************************************************
  21. C APPELe PAR : operateur SORTir (prsort.eso)
  22. C***********************************************************************
  23. C ENTReES : aucune
  24. C SORTIES : aucune (sur fichier uniquement)
  25. C***********************************************************************
  26. C SYNTAXE (GIBIANE) :
  27. C
  28. C OPTI 'SORT' 'fichier.med';
  29. C SORT 'MED' OBJ1 OBJ2 ... OBJi ;
  30. C
  31. C avec OBJi = [ MAILi | CHPOi | TABi ]
  32. C
  33. C***********************************************************************
  34. SUBROUTINE SORMED
  35.  
  36. IMPLICIT INTEGER(i-n)
  37. IMPLICIT REAL*8(a-h,o-z)
  38.  
  39. EXTERNAL LONG
  40. C **********************************************************************
  41. C MODIFICATION CLEMENT BERTHINIER MED_3.X.X
  42. C on met l'include specifique du FORMAT MED
  43. C concatenation de med_parameter.hf77 et med.hf77
  44. C **********************************************************************
  45. -INC CCMED
  46. -INC CCNOYAU
  47. -INC CCASSIS
  48. -INC CCOPTIO
  49. -INC SMELEME
  50. -INC SMCOORD
  51. -INC TMLNOMS
  52. -INC CCGEOME
  53. -INC SMCHPOI
  54. -INC SMCHAML
  55. -INC SMTABLE
  56. -INC SMMODEL
  57. -INC SMLENTI
  58. -INC SMLMOTS
  59.  
  60. C-----Definition des entiers
  61. INTEGER*4 fid
  62. INTEGER*4 access
  63. INTEGER*4 ilon4
  64. INTEGER*4 cret
  65. INTEGER*4 sdim
  66. INTEGER*4 mdim
  67.  
  68. INTEGER*4 mtype
  69. INTEGER*4 stype
  70. INTEGER*4 atype
  71. INTEGER*4 ftype
  72. INTEGER*4 gtype
  73. INTEGER*4 etype
  74.  
  75. INTEGER*4 numdt
  76. INTEGER*4 numit
  77. INTEGER*4 swm
  78. INTEGER*4 ngro
  79. INTEGER*4 fnum
  80. INTEGER*4 cmode
  81. INTEGER*4 cs
  82. INTEGER*4 n
  83. INTEGER*4 ncomp
  84.  
  85. C-----Definition des reels
  86. REAL*8 dt
  87. REAL*8 vcchmp
  88.  
  89. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  90. CHARACTER*(MED_SNAME_SIZE) dtunit
  91.  
  92. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  93. CHARACTER*(MED_NAME_SIZE) name,fname,nomg
  94.  
  95. C-----Chaines de Caractere de longueur MED_LNAME_SIZE=80
  96. CHARACTER*(MED_LNAME_SIZE) gname
  97.  
  98. C-----Chaines de Caractere de longueur MED_COMMENT_SIZE=200
  99. CHARACTER*(MED_COMMENT_SIZE) desc
  100.  
  101. CHARACTER*8 ctyp
  102. CHARACTER*4 cha4F
  103. CHARACTER*8 cha8b, cha8c, cha8d, cha8e
  104. CHARACTER*(LONOM) cha24a,cha24b
  105. CHARACTER*32 fobj
  106. CHARACTER*32 cha32a, cha32b
  107.  
  108. LOGICAL zopen, login, logre, LOG1, LOG2
  109.  
  110. C ***** Declaration des segments
  111. SEGMENT SANAME
  112. CHARACTER*(MED_SNAME_SIZE) ANAME(IDIM)
  113. CHARACTER*(MED_SNAME_SIZE) AUNIT(IDIM)
  114. ENDSEGMENT
  115.  
  116. C-----Information sur les FAMILLES
  117. SEGMENT IJFAM
  118. INTEGER NFAM
  119. INTEGER IFAM(jf)
  120. INTEGER INUMF(jf)
  121. INTEGER INOGRO(jf)
  122. CHARACTER*(MED_NAME_SIZE) CNOMFA(jf)
  123. INTEGER IPROF(jf)
  124. C jf : Entier de dimensionnement
  125. C NFAM : Nombre de familles
  126. C IFAM : Objet MELEME (simple normalement)
  127. C INOGRO : pointeur sur un SEGMENT NOMGRO(Noms des groupes composes de cette famille)
  128. C CNOMFA : Nom de la famille
  129. C IPROF : pointeur sur un SEGMENT IPROFI pour definir le PROFIL
  130. ENDSEGMENT
  131.  
  132. C-----Contiendra les numeros des familles des elements pour chaque type (ITYPEL)
  133. SEGMENT INUMFA(nbelt)
  134.  
  135. C-----SEGMENT pour stocker les profils des familles (numeros d'elements local)
  136. SEGMENT IPROFI(nbelp)
  137.  
  138. C-----SEGMENT pour la numerotation locale (voir bdata.eso & CCGEOME pour NOMBR)
  139. SEGMENT INBTYP(3,NOMBR)
  140. C (1,.) : Nombre d'elements de ce type
  141. C (2,.) : Pointeur MELEME
  142. C (3,.) : Pointeur vers SEGMENT INUMFA
  143.  
  144. C-----NOGROU contient les noms des groupes qui incluent la famille
  145. SEGMENT NOMGRO
  146. INTEGER NOCO
  147. CHARACTER*(MED_LNAME_SIZE) NOGROU(kg)
  148. ENDSEGMENT
  149.  
  150. C-----Information sur les GROUPES
  151. SEGMENT IJGROU
  152. INTEGER ILENTI(nbgrou)
  153. INTEGER IPMAIL(nbgrou)
  154. CHARACTER*(MED_LNAME_SIZE) CNOMGR(nbgrou)
  155. C nbgrou : Nombre de groupes
  156. C ILENTI : pointeur LISTENTI des numeros de famille composant les groupes
  157. C IPMAIL : pointeur MELEME du groupe en question
  158. C CNOMGR : Noms des groupes
  159. ENDSEGMENT
  160.  
  161. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  162.  
  163. SEGMENT ICOO
  164. REAL*8 COO(IDIM,nno)
  165. ENDSEGMENT
  166.  
  167. SEGMENT ISORTA
  168. CHARACTER*8 ISORTC(ks)
  169. CHARACTER*(MED_LNAME_SIZE) NOSORT(ks)
  170. INTEGER ISORTI(ks)
  171. C ks : Nombre d'objets a sortir
  172. C ISORTC : Type de l'objet a sortir (MAILLAGE, CHPOINT, MCHAML, TABLE)
  173. C NOSORT : Nom de l'objet a sortir (si nommé)
  174. C ISORTI : Pointeur de l'objet a sortir
  175. ENDSEGMENT
  176.  
  177. C-----SEGMENT pour traiter les valeurs en INTEGER*4
  178. SEGMENT INT4(itaill)
  179.  
  180. C---- Donnees pour CHPOINT et MCHAML
  181. SEGMENT IFOCHA
  182. CHARACTER*(MED_NAME_SIZE) NOCHAP(nbmspo)
  183. INTEGER PNUMDT(nbmspo)
  184. INTEGER LICHAP(nbmspo)
  185. INTEGER LIMAIL(nbmspo)
  186. INTEGER ISUPOR(nbmspo,2)
  187. REAL*8 XTEMPS(nbmspo)
  188. C nbmspo : nombre de champs a sortir
  189. C NOCHAP : nom du champ a produire
  190. C PNUMDT : numero de pas de temps (numdt)
  191. C LICHAP : liste de pointeurs MSOUPO ou MCHAML
  192. C LIMAIL : liste de pointeurs MELEME
  193. C ISUPOR : type de support (0,1) : Non-Defini (CHPOINT)
  194. C (1,1) : NOEUDS
  195. C (2,1) : GRAVITE
  196. C (N,1) : Non-prevu encore
  197. C (.,2) : Pointeur sur un MINTE (SEGMENT d'INTEGRATION)
  198. C XTEMPS : Valeur du temps pour cet instant
  199. ENDSEGMENT
  200. POINTEUR LISCHP.IFOCHA,LISCHA.IFOCHA
  201.  
  202. C SEGMENT pour repertorier les objets nommes et leur nom
  203. SEGMENT SREPER
  204. INTEGER IREPER(NBENT)
  205. CHARACTER*(LONOM) CREPER(NBENT)
  206. C NBENT : Nombre d'objets
  207. C IREPER : OBJETS (Pointeur ou ENTIER pour les 'POINT')
  208. C CREPER : Noms des OBJETS
  209. ENDSEGMENT
  210. POINTEUR SREPE1.SREPER
  211.  
  212. C Permutation des noeuds MED <-> Cast3M
  213. SEGMENT IPERM(NBNN-1)
  214.  
  215. C SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  216. SEGMENT SID
  217. C NBFUS : NOMBRE D'OBJETS A FUSIONNER
  218. C IPOINT : POINTEURS SUR LES NBFUS OBJETS A FUSIONNER
  219. C BVAL : LOGIQUES A FUSIONNER
  220. C XVAL : VALEURS MAXI / MINI LOCALES A FUSIONNER
  221. C CHATYP : MOT DONNANT LE TYPE D'OBJET A FUSIONNER
  222. INTEGER IPOINT(NBFUS)
  223. LOGICAL BVAL (NBFUS)
  224. REAL*8 XVAL (NBFUS)
  225. CHARACTER*8 CHATYP
  226. ENDSEGMENT
  227.  
  228. SEGMENT ITLAC(0)
  229. POINTEUR ITLAC1.ITLAC
  230.  
  231. SEGMENT IPNON(0)
  232.  
  233. C **********************************************************************
  234. C DEBUT DES INSTRUCTIONS
  235. C **********************************************************************
  236. C-----Appel au menage (Sinon on a des soucis dans TASSPO qui prend des *MOD !)
  237. CALL ECRCHA('OBLI')
  238. CALL MENAGE
  239. SEGACT,MCOORD
  240.  
  241.  
  242. C-----Initialisation
  243. INT4 = 0
  244. ICPR = 0
  245. IJFAM = 0
  246. IJGROU = 0
  247. INUMFA = 0
  248. IPROFI = 0
  249.  
  250. C-----Definition de la liste de CHPOINT & MCHAML
  251. nbmspo = 0
  252. nbmsp = 0
  253. nbchm = 0
  254. SEGINI LISCHP,LISCHA
  255.  
  256. INQUIRE(UNIT = ioper, NAME = nomfic )
  257. CLOSE (UNIT = ioper, STATUS ='DELETE')
  258.  
  259. C **********************************************************************
  260. C Creation/ouverture d'un fichier MED 3.0
  261. C **********************************************************************
  262. ilon4 = LONG(nomfic)
  263. name = nomfic(1:MIN(ilon4,MED_NAME_SIZE))
  264. access = MED_ACC_CREAT
  265.  
  266. CALL mfiope(fid, name, access, cret)
  267. IF (cret .NE. 0) THEN
  268. moterr ='mfiope '//name
  269. interr(1)= cret
  270. CALL ERREUR(873)
  271. RETURN
  272. ENDIF
  273.  
  274. C **********************************************************************
  275. C Creation d'un MAILLAGE dans MED 3.0
  276. C **********************************************************************
  277. C-----Creation du repere cartesien
  278. SEGINI,SANAME
  279. IF (IDIM .EQ. 1)THEN
  280. SANAME.ANAME(1)='X'
  281. SANAME.AUNIT(1)='NO_UNIT'
  282. ELSEIF(IDIM .EQ. 2)THEN
  283. SANAME.ANAME(1)='X'
  284. SANAME.ANAME(2)='Y'
  285. SANAME.AUNIT(1)='NO_UNIT'
  286. SANAME.AUNIT(2)='NO_UNIT'
  287. ELSEIF(IDIM .EQ. 3)THEN
  288. SANAME.ANAME(1)='X'
  289. SANAME.ANAME(2)='Y'
  290. SANAME.ANAME(3)='Z'
  291. SANAME.AUNIT(1)='NO_UNIT'
  292. SANAME.AUNIT(2)='NO_UNIT'
  293. SANAME.AUNIT(3)='NO_UNIT'
  294. ELSE
  295. interr(1)=IDIM
  296. CALL ERREUR(709)
  297. CALL ERREUR(832)
  298. GOTO 9999
  299. ENDIF
  300.  
  301. name ='$MESH_FROM_CAST3M$'
  302. sdim = IDIM
  303. mdim = IDIM
  304. mtype = MED_UNSTRUCTURED_MESH
  305. desc ='MAILLAGE MED sorti par Cast3M'
  306. dtunit ='NO_UNIT'
  307. stype = MED_SORT_DTIT
  308. atype = MED_CARTESIAN
  309.  
  310. CALL mmhcre(fid , name, sdim, mdim, mtype, desc, dtunit, stype,
  311. & atype, SANAME.ANAME, SANAME.AUNIT, cret)
  312. IF (cret .NE. 0) THEN
  313. moterr ='mmhcre'
  314. interr(1)= cret
  315. CALL ERREUR(873)
  316. GOTO 9999
  317. ENDIF
  318.  
  319. SEGINI,ITLAC,IPNON
  320. kss = 0
  321. ks = 100
  322. SEGINI,ISORTA
  323. 1 CONTINUE
  324. INTEXT = 1
  325. ctyp = ' '
  326. cha24a = ' '
  327.  
  328. CALL QUETYP(ctyp, 0, iretou)
  329. IF (iretou .NE. 1) GOTO 100
  330.  
  331. CALL LIROBJ(ctyp, iret, 0, iretou)
  332.  
  333. C ***** On controle que le type est connu de Cast3M
  334. CALL TYPFIL(ctyp, k)
  335.  
  336. IF (k .LT. 0) THEN
  337. C----------On NE sait pas sortir un objet de ce type
  338. moterr = ctyp
  339. CALL ERREUR(242)
  340. GOTO 9999
  341. ENDIF
  342.  
  343. C-------Le type est ok
  344. CALL QUENOM(cha24a)
  345. ilon2 = LONG(cha24a)
  346.  
  347. IF (ctyp .EQ. 'MAILLAGE') THEN
  348. C **************************************************************
  349. C * Demande des MAILLAGE *
  350. C **************************************************************
  351. CALL ACTOBJ('MAILLAGE',iret,1)
  352. MELEME = iret
  353. CALL AJOU(ITLAC,MELEME)
  354. DO JJ = 1,LISOUS(/1)
  355. IVAL = LISOUS(JJ)
  356. CALL AJOU(ITLAC,IVAL)
  357. ENDDO
  358.  
  359. ELSEIF (ctyp .EQ. 'CHPOINT ') THEN
  360. C **************************************************************
  361. C * Demande des CHPOINT *
  362. C **************************************************************
  363. CALL ACTOBJ('CHPOINT ',iret,1)
  364. MCHPOI = iret
  365. nbzone = MCHPOI.IPCHP(/1)
  366.  
  367. DO 21 II = 1,nbzone
  368. MSOUPO = MCHPOI.IPCHP(II)
  369. IPT1 = MSOUPO.IGEOC
  370. IF(IPT1.NUM(/2) .EQ. 0)GOTO 21
  371. CALL AJOU(ITLAC,IPT1)
  372. CALL AJOU(IPNON,IPT1)
  373.  
  374. IF(nbzone .EQ. 1)THEN
  375. fname = cha24a
  376. ELSE
  377. C Determination du FORMAT automatique
  378. IFORMA = INT(LOG10(REAL(II))) + 1
  379. cha4F='(I )'
  380. IF (IFORMA.GE.1 .AND. IFORMA.LT.9)THEN
  381. WRITE(cha4F(3:3), '(I1)') IFORMA
  382. WRITE(cha8c,cha4F)II
  383. ELSE
  384. CALL ERREUR(1094)
  385. GOTO 9999
  386. ENDIF
  387. fname = cha24a(1:ilon2)//'_'//cha8c
  388. ENDIF
  389.  
  390. nbmsp = nbmsp + 1
  391. IF (nbmsp .GT. LISCHP.LICHAP(/1)) THEN
  392. nbmspo = nbmspo*2+20
  393. SEGADJ,LISCHP
  394. ENDIF
  395.  
  396. LISCHP.NOCHAP(nbmsp) = fname
  397. LISCHP.PNUMDT(nbmsp) = MED_NO_DT
  398. LISCHP.LICHAP(nbmsp) = MSOUPO
  399. LISCHP.LIMAIL(nbmsp) = IPT1
  400. LISCHP.ISUPOR(nbmsp,1) = 0
  401. LISCHP.ISUPOR(nbmsp,2) = 0
  402. LISCHP.XTEMPS(nbmsp) = MED_UNDEF_DT
  403. 21 CONTINUE
  404.  
  405. ELSEIF (ctyp .EQ. 'MCHAML ') THEN
  406. C ********************************************************
  407. C * INDICE DE TYPE 'MCHAML' *
  408. C ********************************************************
  409. CALL ACTOBJ('MCHAML ',iret,1)
  410. MCHELM = iret
  411. nbzone = MCHELM.ICHAML(/1)
  412.  
  413. nbz = 0
  414. DO 11 II = 1,nbzone
  415. IPT1 = MCHELM.IMACHE(II)
  416. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 11
  417. CALL AJOU(ITLAC,IPT1)
  418. nbz = nbz + 1
  419. 11 CONTINUE
  420.  
  421. C Extraction de la liste des constituants communs (LISTMOTS)
  422. JGN = NCONCH
  423. JGM = nbz
  424. SEGINI,MLMOTS
  425. JGM = 0
  426. DO 12 II = 1,nbzone
  427. IPT1 = MCHELM.IMACHE(II)
  428. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 12
  429. CALL PLACE(MLMOTS.MOTS,JGM,iplace,MCHELM.CONCHE(II))
  430. IF(iplace .EQ. 0)THEN
  431. JGM = JGM + 1
  432. MLMOTS.MOTS(JGM)=MCHELM.CONCHE(II)
  433. ENDIF
  434. 12 CONTINUE
  435.  
  436. DO 13 II = 1,nbzone
  437. IPT1 = MCHELM.IMACHE(II)
  438. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 13
  439. MCHAM1 = MCHELM.ICHAML(II)
  440.  
  441. ISUPP = MCHELM.INFCHE(II,6)
  442. IPMINT = MCHELM.INFCHE(II,4)
  443.  
  444. IF(ISUPP .LE.2)THEN
  445. MCHAML = MCHAM1
  446. ELSE
  447. CALL ERREUR(609)
  448. GOTO 9999
  449. ENDIF
  450.  
  451. IF(JGM .EQ. 1)THEN
  452. fname = cha24a(1:ilon2)
  453. ELSE
  454. C Determination du FORMAT automatique
  455. CALL PLACE(MLMOTS.MOTS,JGM,iplace,MCHELM.CONCHE(II))
  456. IFORMA = INT(LOG10(REAL(II))) + 1
  457. cha4F='(I )'
  458. IF (IFORMA.GE.1 .AND. IFORMA.LT.9)THEN
  459. WRITE(cha4F(3:3), '(I1)') IFORMA
  460. WRITE(cha8c,cha4F)iplace
  461. ELSE
  462. CALL ERREUR(1094)
  463. GOTO 9999
  464. ENDIF
  465. fname = cha24a(1:ilon2)//'_'//cha8c
  466. ENDIF
  467.  
  468. nbchm = nbchm + 1
  469. IF (nbchm .GT. LISCHA.LICHAP(/1)) THEN
  470. nbmspo = nbmspo*2+20
  471. SEGADJ,LISCHA
  472. ENDIF
  473.  
  474. LISCHA.NOCHAP(nbchm) = fname
  475. LISCHA.PNUMDT(nbchm) = MED_NO_DT
  476. LISCHA.LICHAP(nbchm) = MCHAML
  477. LISCHA.LIMAIL(nbchm) = IPT1
  478. LISCHA.ISUPOR(nbchm,1) = ISUPP
  479. LISCHA.ISUPOR(nbchm,2) = IPMINT
  480. LISCHA.XTEMPS(nbchm) = MED_UNDEF_DT
  481. 13 CONTINUE
  482.  
  483. ELSEIF (ctyp .EQ. 'TABLE ') THEN
  484. C------- On sort une TABLE PASAPAS
  485. MTABLE = iret
  486. C---------On verifie que ça soit bien une table PASAPAS
  487. cha8b='MOT '
  488. CALL ACCTAB(MTABLE,cha8b,ival,xval1,'SOUSTYPE',login,iobin,
  489. & cha8b,ivalre,xvalre,cha8c,logre,iobre)
  490. IF(IERR .NE. 0) GOTO 9999
  491. IF (cha8c.NE.'PASAPAS ') THEN
  492. MOTERR='PASAPAS'
  493. CALL ERREUR(-173)
  494. CALL ERREUR(21)
  495. GOTO 9999
  496. ENDIF
  497.  
  498. ELSE
  499. C---------On NE sait pas sortir ce type d'objet
  500. moterr = ctyp
  501. CALL ERREUR(242)
  502. GOTO 9999
  503. ENDIF
  504.  
  505. kss = kss + 1
  506. IF( kss .GT. ks)THEN
  507. ks = ks * 2 + 100
  508. SEGADJ,ISORTA
  509. ENDIF
  510. NOSORT(kss) = cha24a
  511. ISORTC(kss) = ctyp
  512. ISORTI(kss) = iret
  513. GOTO 1
  514.  
  515. C-----On a explore toutes les demandes
  516. 100 CONTINUE
  517.  
  518. IF (kss .EQ. 0) THEN
  519. C-------Rien a sortir...
  520. CALL ERREUR(-365)
  521. GOTO 9999
  522. ENDIF
  523.  
  524. C **********************************************************************
  525. C TRAITEMENT DES DEMANDES pour remplir la liste des maillages
  526. C **********************************************************************
  527. C-----Parcours de la liste des OBJETS a sortir pour trouver les MELEME
  528. if(nbesc.ne.0) SEGACT IPILOC
  529. DO ia = 1,kss
  530. IF (ISORTC(ia) .EQ. 'TABLE ') THEN
  531. C **************************************************************
  532. C * Demande des TABLE *
  533. C **************************************************************
  534. MTABLE = ISORTI(ia)
  535. cha24a = NOSORT(ia)
  536.  
  537. cha8b ='MMODEL '
  538. CALL ACCTAB(MTABLE,'MOT',ival ,xval1 ,'MODELE',login,iobin,
  539. & cha8b,ivalre,xvalre,cha8c ,logre,iobre)
  540. MMODEL = iobre
  541. CALL ACTOBJ('MMODEL ',MMODEL,1)
  542. nsous = MMODEL.KMODEL(/1)
  543. DO 80 isous=1,nsous
  544. IMODEL = MMODEL.KMODEL(isous)
  545. IPT1 = IMODEL.IMAMOD
  546. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 80
  547. CALL AJOU(ITLAC,IPT1)
  548. 80 CONTINUE
  549.  
  550. cha8b = 'TABLE '
  551. CALL ACCTAB(MTABLE,'MOT',ival10,xval10,'TEMPS',login,iob10,
  552. & cha8b,ival11,xval11,cha8c ,logre,iob11)
  553. IF(IERR .NE. 0) GOTO 9999
  554. C Reactivation de la TABLE desactivee dans ACCTAB
  555. SEGACT,MTABLE
  556. if(nbesc.ne.0) SEGACT IPILOC
  557.  
  558. MTAB1 = iob11
  559. SEGACT,MTAB1
  560. nbtps = MTAB1.MLOTAB
  561.  
  562. C---------Boucle sur tous les indices afin de chercher des champ a sortir
  563. nbind = MTABLE.MLOTAB
  564. DO 90 ib=1,nbind
  565. C-----------Recherche d'une table de CHPOINT ou MCHAML
  566. cha8b = MTABLE.MTABTV(ib)
  567. ip = MTABLE.MTABII(ib)
  568. nd = IPCHAR(ip)
  569. nf = IPCHAR(ip+1)
  570. IF ((nf-nd) .GT. 32) THEN
  571. INTERR(1)=32
  572. MOTERR =ICHARA(nd:nd+31)
  573. CALL ERREUR(1096)
  574. GOTO 9999
  575. ENDIF
  576. cha32a = ICHARA(nd:nf-1)
  577. ilon2 = LONG(cha32a)
  578. IF ((cha8b .NE.'TABLE ').OR.(cha32a(1:6).EQ.'TEMPS ') .OR.
  579. & (cha32a(1:10).EQ.'REACTIONS ')) GOTO 90
  580.  
  581. MTAB2 = MTABLE.MTABIV(ib)
  582. SEGACT,MTAB2
  583. nbtps2 = MTAB2.MLOTAB
  584. IF (nbtps .NE. nbtps2) GOTO 90
  585.  
  586. C-----------Verification de l'uniformite de tous les indices
  587. cha8b = MTAB2.MTABTV(1)
  588. IF ((cha8b.NE.'CHPOINT ').AND.(cha8b.NE.'MCHAML ')) GOTO 90
  589.  
  590. DO ic=1,nbtps
  591. ip1 = MTAB1.MTABII(ic)
  592. ip2 = MTAB2.MTABII(ic)
  593. cha8c = MTAB2.MTABTV(ic)
  594. IF ((ip1.NE.ip2).OR.(cha8b.NE.cha8c)) GOTO 90
  595. ENDDO
  596.  
  597. C-----------Boucle sur les indice SAUVES de la TABLE
  598. DO ic=1,nbtps
  599. IF (cha8b .EQ. 'CHPOINT ') THEN
  600. C ********************************************************
  601. C * INDICE DE TYPE 'CHPOINT' *
  602. C ********************************************************
  603. MCHPOI = MTAB2.MTABIV(ic)
  604. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  605. nbzone = MCHPOI.IPCHP(/1)
  606.  
  607. DO 95 II = 1,nbzone
  608. MSOUPO = MCHPOI.IPCHP(II)
  609. IPT1 = MSOUPO.IGEOC
  610. IF(IPT1.NUM(/2) .EQ. 0) GOTO 95
  611. CALL AJOU(ITLAC,IPT1)
  612. CALL AJOU(IPNON,IPT1)
  613.  
  614. IF(nbzone .EQ. 1)THEN
  615. fname = cha32a(1:ilon2)
  616. ELSE
  617. C Determination du FORMAT automatique
  618. IFORMA = INT(LOG10(REAL(II))) + 1
  619. cha4F='(I )'
  620. IF (IFORMA.GE.1 .AND. IFORMA.LT.9)THEN
  621. WRITE(cha4F(3:3), '(I1)') IFORMA
  622. WRITE(cha8c,cha4F)II
  623. ELSE
  624. CALL ERREUR(1094)
  625. GOTO 9999
  626. ENDIF
  627. fname = cha32a(1:ilon2)//'_'//cha8c
  628. ENDIF
  629.  
  630. nbmsp = nbmsp + 1
  631. IF (nbmsp .GT. LISCHP.LICHAP(/1)) THEN
  632. nbmspo = nbmspo*2+20
  633. SEGADJ,LISCHP
  634. ENDIF
  635. LISCHP.NOCHAP(nbmsp) = fname
  636. LISCHP.PNUMDT(nbmsp) = MTAB1.MTABII(ic)
  637. LISCHP.LICHAP(nbmsp) = MSOUPO
  638. LISCHP.LIMAIL(nbmsp) = IPT1
  639. LISCHP.ISUPOR(nbmsp,1) = 0
  640. LISCHP.ISUPOR(nbmsp,2) = 0
  641. LISCHP.XTEMPS(nbmsp) = MTAB1.RMTABV(ic)
  642. 95 CONTINUE
  643.  
  644. ELSEIF (cha8b .EQ. 'MCHAML ') THEN
  645. C ********************************************************
  646. C * INDICE DE TYPE 'MCHAML' *
  647. C ********************************************************
  648. MCHELM = MTAB2.MTABIV(ic)
  649. CALL ACTOBJ('MCHAML ',MCHELM,1)
  650. nbzone = MCHELM.ICHAML(/1)
  651.  
  652. C Verification s'il faut passer aux noeuds certaines zones
  653. ICHSUP=0
  654. nbz =0
  655. DO 91 II = 1,nbzone
  656. IPT1 = MCHELM.IMACHE(II)
  657. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 91
  658. CALL AJOU(ITLAC,IPT1)
  659.  
  660. ISUPP = MCHELM.INFCHE(II,6)
  661. IF(ISUPP .GT. 2)THEN
  662. ICHSUP=1
  663. ENDIF
  664. nbz = nbz + 1
  665. 91 CONTINUE
  666.  
  667. IF(ICHSUP .EQ. 1)THEN
  668. C Chgt de support aux Noeuds
  669. ISUPP = 1
  670. CALL REDUAF(MCHELM,MMODEL,MCHEL2,0,iret,kerre)
  671. IF(IRET .NE. 1) CALL ERREUR(kerre)
  672. IF(IERR .NE. 0) RETURN
  673. CALL CHASUP(MMODEL,MCHEL2,MCHELM,IRET,ISUPP)
  674. IF(IRET .NE. 0) THEN
  675. PRINT *,' ERREUR indice:''',fname(1:ilon2),''''
  676. CALL ERREUR(IRET)
  677. GOTO 9999
  678. ENDIF
  679. nbzone=ICHAML(/1)
  680. ENDIF
  681.  
  682. C Extraction de la liste des constituants communs (LISTMOTS)
  683. JGN = NCONCH
  684. JGM = nbz
  685. SEGINI,MLMOTS
  686. JGM = 0
  687. nbz2=MCHELM.ICHAML(/1)
  688. DO 92 II = 1,nbzone
  689. IPT1 = MCHELM.IMACHE(II)
  690. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 92
  691. CALL PLACE(MLMOTS.MOTS,JGM,iplace,MCHELM.CONCHE(II))
  692. IF(iplace .EQ. 0)THEN
  693. JGM = JGM + 1
  694. MLMOTS.MOTS(JGM)=MCHELM.CONCHE(II)
  695. ENDIF
  696. 92 CONTINUE
  697.  
  698. DO 93 II = 1,nbzone
  699. IPT1 = MCHELM.IMACHE(II)
  700. IF(MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 93
  701. MCHAML = MCHELM.ICHAML(II)
  702.  
  703. ISUPP = MCHELM.INFCHE(II,6)
  704. IPMINT = MCHELM.INFCHE(II,4)
  705.  
  706. IF(JGM .EQ. 1)THEN
  707. fname = cha32a(1:ilon2)
  708. ELSE
  709. C Determination du FORMAT automatique
  710. CALL PLACE(MLMOTS.MOTS,JGM,iplace,MCHELM.CONCHE(II))
  711. IFORMA = INT(LOG10(REAL(II))) + 1
  712. cha4F='(I )'
  713. IF (IFORMA.GE.1 .AND. IFORMA.LT.9)THEN
  714. WRITE(cha4F(3:3), '(I1)') IFORMA
  715. WRITE(cha8c,cha4F)iplace
  716. ELSE
  717. CALL ERREUR(1094)
  718. GOTO 9999
  719. ENDIF
  720. fname = cha32a(1:ilon2)//'_'//cha8c
  721. ENDIF
  722.  
  723. nbchm = nbchm + 1
  724. IF (nbchm .GT. LISCHA.LICHAP(/1)) THEN
  725. nbmspo = nbmspo*2+20
  726. SEGADJ,LISCHA
  727. ENDIF
  728.  
  729. LISCHA.NOCHAP(nbchm) = fname
  730. LISCHA.PNUMDT(nbchm) = MTAB1.MTABII(ic)
  731. LISCHA.LICHAP(nbchm) = MCHAML
  732. LISCHA.LIMAIL(nbchm) = IPT1
  733. LISCHA.ISUPOR(nbchm,1) = ISUPP
  734. LISCHA.ISUPOR(nbchm,2) = IPMINT
  735. LISCHA.XTEMPS(nbchm) = MTAB1.RMTABV(ic)
  736. 93 CONTINUE
  737. ENDIF
  738. ENDDO
  739.  
  740. SEGDES,MTAB2
  741. 90 CONTINUE
  742. ENDIF
  743. ENDDO
  744. if(nbesc.ne.0) SEGDES,IPILOC
  745.  
  746. C **********************************************************************
  747. C Union des MELEME et creation des GROUPES
  748. C **********************************************************************
  749. NBFUS=ITLAC(/1)
  750. IF (NBFUS .EQ. 1) THEN
  751. IPT8 = ITLAC(1)
  752. ELSEIF (NBFUS .GT. 1) THEN
  753. SEGINI,SID
  754. SID.CHATYP='MAILLAGE'
  755. DO iii=1,NBFUS
  756. SID.IPOINT(iii)=ITLAC(iii)
  757. ENDDO
  758. LOG1=.FALSE.
  759. LOG2=.FALSE.
  760. CALL FUNOBJ(SID,IPT8,XBID1,LOG1,LOG2)
  761. SEGSUP,SID
  762. ELSE
  763. CALL ERREUR(5)
  764. ENDIF
  765.  
  766. C Ajout des MELEME nommes inclus strictement dans IPT8
  767. CALL NOEINC(IPT8,'MAILLAGE',SREPER)
  768. NBENT=SREPER.IREPER(/1)
  769.  
  770. C On a besoin de tous les MAILLAGES : Ceux pas nommes --> num du pointeur
  771. NBMAIL=ITLAC(/1)
  772. NBNOM =NBENT
  773. NBENT =NBNOM+NBMAIL
  774. SEGADJ,SREPER
  775. NBENT =NBNOM
  776. NBOUT =IPNON(/1)
  777. DO 20 ii=1,NBMAIL
  778. IPT1 = ITLAC(ii)
  779. IF(NBOUT .GT. 0) CALL PLACE2(IPNON(1),NBOUT,IDANS,IPT1)
  780. IF(IDANS .NE. 0) GOTO 20
  781.  
  782. CALL PLACE2(SREPER.IREPER(1),NBENT,IDANS,IPT1)
  783. IF(IDANS .EQ. 0)THEN
  784. C MAILLAGE A Ajouter
  785. NBENT=NBENT+1
  786.  
  787. C Determination du FORMAT automatique
  788. IFORMA = INT(LOG10(REAL(IPT1))) + 1
  789. cha4F='(I )'
  790. IF (IFORMA.GE.1 .AND. IFORMA.LT.9)THEN
  791. WRITE(cha4F(3:3), '(I1)') IFORMA
  792. WRITE(cha8c,cha4F)IPT1
  793. ELSE
  794. CALL ERREUR(1094)
  795. GOTO 9999
  796. ENDIF
  797.  
  798. C Les pointeurs negatifs serviront a ne pas creer de FAMILLE supplementaire
  799. SREPER.IREPER(NBENT)=-IPT1
  800. SREPER.CREPER(NBENT)= cha8c
  801. ENDIF
  802. 20 CONTINUE
  803. SEGADJ,SREPER
  804.  
  805. C **********************************************************************
  806. C TASSEMENT DES NOEUDS DANS CAST3M : RENUMEROTATION sans optimiser ('NOOP')
  807. C **********************************************************************
  808. CALL ECRCHA('NOOP')
  809. SEGINI,ITLAC1=ITLAC
  810. CALL TASSPO(ITLAC, icolac, MELEME, 0)
  811. CALL SUPPIL(icolac,-1)
  812. IF (IERR .NE. 0) GOTO 9999
  813. ITLAC=ITLAC1
  814.  
  815. C **********************************************************************
  816. C Ecriture des coordonnees des noeuds
  817. C **********************************************************************
  818. C-----Reperage du numeros de noeuds nno (imin=1 apres TASSPO)
  819. nno = 0
  820. imin = 0
  821. DO ii=1,NBMAIL
  822. IPT8 = ITLAC(ii)
  823. ISOUS = MAX(IPT8.LISOUS(/1),1)
  824. DO ik = 1,ISOUS
  825. IF (ISOUS .EQ. 1) THEN
  826. IPT1 = IPT8
  827. ELSE
  828. IPT1 = IPT8.LISOUS(ik)
  829. ENDIF
  830.  
  831. DO j = 1,IPT1.NUM(/2)
  832. DO i = 1,IPT1.NUM(/1)
  833. inoeu= IPT1.NUM(i,j)
  834. IF(nno .EQ. 0)THEN
  835. nno = inoeu
  836. ELSE
  837. nno = MAX(nno,inoeu)
  838. ENDIF
  839. IF(imin .EQ. 0)THEN
  840. imin = inoeu
  841. ELSE
  842. imin = MIN(imin,inoeu)
  843. ENDIF
  844. ENDDO
  845. ENDDO
  846. ENDDO
  847. ENDDO
  848.  
  849. C-----Copie des coordonnees des noeuds compris entre 1 et nno
  850. SEGINI,ICOO
  851. DO i = 1,nno
  852. ival1=(i-1)*(IDIM+1)
  853. DO j = 1,IDIM
  854. COO(j,i) = XCOOR(ival1+j)
  855. ENDDO
  856. ENDDO
  857.  
  858. numdt = MED_NO_DT
  859. numit = MED_NO_IT
  860. dt = 0.D0
  861. swm = MED_FULL_INTERLACE
  862. n = nno
  863.  
  864. CALL mmhcow(fid, name, numdt, numit, dt, swm, n, COO, cret)
  865. IF (cret .NE. 0) THEN
  866. moterr ='mmhcow'
  867. interr(1)= cret
  868. CALL ERREUR(873)
  869. GOTO 9999
  870. ENDIF
  871.  
  872. C **********************************************************************
  873. C Creation des FAMILLES
  874. C **********************************************************************
  875. C +-----------------------------------------------------------------+
  876. C |FAMILLE 0 de nom 'FAMILLE_ZERO' (OBLIGATOIRE) : comporte 0 groupe
  877. C +-----------------------------------------------------------------+
  878. fname ='FAMILLE_ZERO'
  879. fnum = 0
  880. ngro = 0
  881. gname =' '
  882. CALL mfacre(fid, name, fname, fnum, ngro, gname, cret)
  883. IF (cret .NE. 0) THEN
  884. moterr ='mfacre'
  885. interr(1) = cret
  886. CALL ERREUR(873)
  887. GOTO 9999
  888. ENDIF
  889.  
  890. C +-----------------------------------------------------------------+
  891. C |FAMILLE des POINTS nommes : Numerotation positive ou nulle
  892. C +-----------------------------------------------------------------+
  893. C Reperage des POINT nommes strictement inclus dans IPT8
  894. CALL NOEINC(IPT8,'POINT ',SREPE1)
  895. nbpoi1=SREPE1.IREPER(/1)
  896.  
  897. IF (nbpoi1 .NE. 0) THEN
  898. kg = 1
  899. SEGINI,NOMGRO
  900. NOMGRO.NOCO = 1
  901.  
  902. nbelt = nno
  903. SEGINI,INUMFA
  904.  
  905. DO 110 indice = 1,nbpoi1
  906. iob = SREPE1.IREPER(indice)
  907. IF (INUMFA(iob) .NE. 0) GOTO 110
  908.  
  909. INUMFA(iob) = indice
  910. NOMGRO.NOGROU(1) = SREPE1.CREPER(indice)
  911.  
  912. C Determination du FORMAT automatique
  913. IFORMA = INT(LOG10(REAL(indice))) + 1
  914. ilong = 3+IFORMA
  915. cha4F ='(I )'
  916. fobj = 'FAP'
  917. IF (IFORMA.GE.1 .AND. IFORMA.LT.9) THEN
  918. WRITE(cha4F(3:3) ,FMT='(I1)') IFORMA
  919. WRITE(fobj(4:3+IFORMA),FMT= cha4F) indice
  920. ELSE
  921. CALL ERREUR(1094)
  922. GOTO 9999
  923. ENDIF
  924.  
  925. C ***** Creation des familles des POINTS nommes dans Cast3M
  926. fname = fobj(1:ilong)
  927. fnum = indice
  928. ngro = NOMGRO.NOCO
  929.  
  930. CALL mfacre (fid,name, fname, fnum, ngro, NOMGRO.NOGROU, cret)
  931. IF (cret .NE. 0) THEN
  932. moterr ='mfacre'
  933. interr(1) = cret
  934. CALL ERREUR(873)
  935. GOTO 9999
  936. ENDIF
  937. 110 CONTINUE
  938.  
  939. C ***** Ecriture des numeros de famille des POINTS nommes dans Cast3M
  940. numdt = MED_NO_DT
  941. numit = MED_NO_IT
  942. etype = MED_NODE
  943. gtype = MED_NONE
  944. n = nno
  945.  
  946. itaill = n
  947. SEGINI,INT4
  948. CALL mhfnw4 (fid, name, numdt, numit, etype, gtype , n,
  949. & INUMFA(1), INT4(1), cret)
  950. IF (cret .NE. 0) THEN
  951. moterr ='mhfnw4'
  952. interr(1) = cret
  953. CALL ERREUR(873)
  954. GOTO 9999
  955. ENDIF
  956.  
  957. SEGSUP,INT4,NOMGRO
  958. ENDIF
  959. SEGSUP,SREPE1
  960.  
  961. C +-----------------------------------------------------------------+
  962. C |FAMILLE d''elements : Numerotation negative ou nulle
  963. C +-----------------------------------------------------------------+
  964. nbgrou = NBENT
  965. jf = 20
  966. SEGINI,IJGROU,IJFAM
  967. NFA = 0
  968. DO 40 ii=1,nbgrou
  969. log1 = SREPER.IREPER(ii) .LT. 0
  970. IPT1 = ABS(SREPER.IREPER(ii))
  971. nomg = SREPER.CREPER(ii)
  972. IJGROU.IPMAIL(ii)=IPT1
  973. IJGROU.CNOMGR(ii)=nomg
  974.  
  975. NBSOUS = IPT1.LISOUS(/1)
  976. NBSO1 = MAX(NBSOUS,1)
  977.  
  978. jg = NBSO1
  979. SEGINI,MLENTI
  980. IJGROU.ILENTI(ii)=MLENTI
  981.  
  982. jg = 0
  983. DO 401 ISOU=1,NBSO1
  984. IF(NBSOUS .EQ. 0)THEN
  985. IPT2 = IPT1
  986. ELSE
  987. IPT2 = IPT1.LISOUS(ISOU)
  988. ENDIF
  989. itype = IPT2.ITYPEL
  990.  
  991. C Gestion des types d'elements non traites actuellement
  992. IF(MEDEL(itype) .EQ. MED_NONE) GOTO 401
  993.  
  994. C Recherche de ce MELEME dans les FAMILLES existantes
  995. CALL PLACE2(IJFAM.IFAM,NFA,IDANS,IPT2)
  996. IF(IDANS .EQ. 0)THEN
  997. NFA = NFA + 1
  998. IDANS= NFA
  999. IF(IDANS .GT. jf)THEN
  1000. jf = IDANS*2 + 20
  1001. SEGADJ,IJFAM
  1002. ENDIF
  1003.  
  1004. C Determination du FORMAT automatique
  1005. IFORMA= INT(LOG10(REAL(IDANS))) + 1
  1006. ilong = 9+IFORMA
  1007. cha4F ='(I )'
  1008. fname ='FAM_'//NOMS(itype)//'_'
  1009. IF (IFORMA.GE.1 .AND. IFORMA.LT.9) THEN
  1010. WRITE(cha4F(3:3) ,FMT='(I1)') IFORMA
  1011. WRITE(fname(10:ilong),FMT= cha4F) IDANS
  1012. ELSE
  1013. CALL ERREUR(1094)
  1014. GOTO 9999
  1015. ENDIF
  1016.  
  1017. kg=20
  1018. SEGINI,NOMGRO
  1019.  
  1020. IJFAM.IFAM(IDANS) = IPT2
  1021. IJFAM.INUMF(IDANS) =-IDANS
  1022. IJFAM.INOGRO(IDANS) = NOMGRO
  1023. IJFAM.CNOMFA(IDANS) = fname
  1024.  
  1025. ELSE
  1026. NOMGRO= IJFAM.INOGRO(IDANS)
  1027. ENDIF
  1028.  
  1029. C Il faut repenser LIRE 'MED' avant de decommenter le IF qui suit
  1030. C IF (LOG1) THEN
  1031. C IJFAM.INUMF(IDANS)= 0
  1032. C ELSE
  1033. kg = NOMGRO.NOGROU(/2)
  1034. NOC = NOMGRO.NOCO + 1
  1035. IF(NOC .GT. kg)THEN
  1036. kg = NOC*2 + 20
  1037. SEGADJ,NOMGRO
  1038. ENDIF
  1039. NOMGRO.NOCO = NOC
  1040. NOMGRO.NOGROU(NOC) = nomg
  1041. C ENDIF
  1042.  
  1043. jg = jg + 1
  1044. MLENTI.LECT(jg) = IDANS
  1045. 401 CONTINUE
  1046. SEGADJ,MLENTI
  1047. 40 CONTINUE
  1048. IJFAM.NFAM=NFA
  1049.  
  1050. C---- Recomposition MAILLAGE global & Ecriture des familles dans MED
  1051. SEGINI,INBTYP
  1052. DO 41 iou = 1,NFA
  1053. IPT1 =IJFAM.IFAM(iou)
  1054. fnum =IJFAM.INUMF(iou)
  1055. itype =IPT1.ITYPEL
  1056. nbnn =IPT1.NUM(/1)
  1057. nbelp =IPT1.NUM(/2)
  1058.  
  1059. SEGINI,IPROFI
  1060. IJFAM.IPROF(iou)=IPROFI
  1061.  
  1062. C------ Accretion des maillages du meme type (ITYPEL)
  1063. INUMFA = INBTYP(3,itype)
  1064. nbini = INBTYP(1,itype)
  1065. nbelt = nbini + nbelp
  1066. nbelem = nbelt
  1067. NBSOUS = 0
  1068. NBREF = 0
  1069. IF(INUMFA .EQ. 0)THEN
  1070. INBTYP(1,itype) = nbelt
  1071. SEGINI,INUMFA
  1072. INBTYP(3,itype) = INUMFA
  1073. nbelem = nbelt
  1074. SEGINI,IPT2
  1075. IPT2.ITYPEL=itype
  1076. INBTYP(2,itype) = IPT2
  1077.  
  1078. ELSE
  1079. INBTYP(1,itype) = nbelt
  1080. SEGADJ,INUMFA
  1081. IPT2 = INBTYP(2,itype)
  1082. SEGADJ,IPT2
  1083. ENDIF
  1084.  
  1085. C Profil des MAILLAGES et permutation des noeuds Cast3M -> MED
  1086. CALL MEDPER(itype, nbnn, IPERM)
  1087. ielt = nbini
  1088. IF (IPERM .NE. 0)THEN
  1089. do iel=1,nbelp
  1090. INUMFA(nbini + iel) = fnum
  1091. IPROFI(iel) = nbini+iel
  1092. ielt = ielt + 1
  1093. IPT2.NUM(1,ielt)=IPT1.NUM(1,iel)
  1094. do ino = 1,nbnn-1
  1095. IPT2.NUM(ino+1,ielt)=IPT1.NUM(IPERM(ino),iel)
  1096. enddo
  1097. enddo
  1098. SEGSUP,IPERM
  1099.  
  1100. ELSE
  1101. DO iel=1,nbelp
  1102. INUMFA(nbini + iel) = fnum
  1103. IPROFI(iel) = nbini+iel
  1104. ielt = ielt + 1
  1105. DO ino=1,nbnn
  1106. IPT2.NUM(ino,ielt)=IPT1.NUM(ino,iel)
  1107. ENDDO
  1108. ENDDO
  1109. ENDIF
  1110.  
  1111. IF(fnum .EQ. 0) GOTO 41
  1112. fname = IJFAM.CNOMFA(iou)
  1113. NOMGRO = IJFAM.INOGRO(iou)
  1114. ngro = NOMGRO.NOCO
  1115. CALL mfacre(fid, name, fname, fnum, ngro, NOMGRO.NOGROU, cret)
  1116. IF (cret .NE. 0) THEN
  1117. moterr ='mfacre'
  1118. interr(1) = cret
  1119. CALL ERREUR(873)
  1120. GOTO 9999
  1121. ENDIF
  1122. 41 CONTINUE
  1123.  
  1124. C Boucle sur tous les TYPES d'elements ('POI1',etc...)
  1125. DO 50 iou = 1,NOMBR
  1126. IPT1 =INBTYP(2,iou)
  1127. IF(IPT1 .EQ. 0) GOTO 50
  1128. itype =IPT1.ITYPEL
  1129. nbnn =IPT1.NUM(/1)
  1130. nbelem=IPT1.NUM(/2)
  1131.  
  1132. INUMFA=INBTYP(3,iou)
  1133.  
  1134. C------ Ecriture des connectivites
  1135. numdt = MED_NO_DT
  1136. numit = MED_NO_IT
  1137. dt = 0.D0
  1138. etype = MED_CELL
  1139. gtype = MEDEL(itype)
  1140. cmode = MED_NODAL
  1141. swm = MED_FULL_INTERLACE
  1142. n = nbelem
  1143.  
  1144. itaill = nbnn * nbelem
  1145. SEGINI,INT4
  1146. CALL mhcyw4 (fid, name, numdt, numit, dt, etype, gtype , cmode,
  1147. & swm, n, IPT1.NUM, INT4(1), cret, itaill)
  1148. IF (cret .NE. 0) THEN
  1149. moterr ='mhcyw4'
  1150. interr(1) = cret
  1151. CALL ERREUR(873)
  1152. GOTO 9999
  1153. ENDIF
  1154. SEGSUP,INT4
  1155.  
  1156. C------ Ecriture du numero de famille a laquelle appartiennent les ELEMENTS
  1157. numdt = MED_NO_DT
  1158. numit = MED_NO_IT
  1159.  
  1160. itaill = nbelem
  1161. SEGINI,INT4
  1162. CALL mhfnw4(fid, name, numdt, numit, etype, gtype , n,
  1163. & INUMFA(1), INT4(1), cret)
  1164. IF (cret .NE. 0) THEN
  1165. moterr ='mhfnw4'
  1166. interr(1) = cret
  1167. CALL ERREUR(873)
  1168. GOTO 9999
  1169. ENDIF
  1170. SEGSUP,INT4
  1171.  
  1172. 50 CONTINUE
  1173. SEGSUP,INBTYP
  1174.  
  1175. C **********************************************************************
  1176. C Ecriture des CHPOINTS : Creation champs MED: profils et valeurs
  1177. C **********************************************************************
  1178. IF (nbmsp .GT. 0) THEN
  1179. nbmspo = nbmsp
  1180. SEGADJ,LISCHP
  1181. CALL SMDCHP(fid, name, IJGROU, LISCHP)
  1182. IF (ierr .NE. 0) GOTO 9999
  1183. ENDIF
  1184.  
  1185. C **********************************************************************
  1186. C Ecriture des MCHAML : Creation champs MED: profils et valeurs
  1187. C **********************************************************************
  1188. IF (nbchm .GT. 0) THEN
  1189. nbmspo = nbchm
  1190. SEGADJ,LISCHA
  1191. CALL SMDCHM(fid, name, IJFAM, IJGROU, LISCHA)
  1192. IF (ierr .NE. 0) GOTO 9999
  1193. ENDIF
  1194.  
  1195. C **********************************************************************
  1196. C Fermeture d'un fichier MED 3.0
  1197. C **********************************************************************
  1198. 9999 CONTINUE
  1199. CALL mficlo (fid, cret)
  1200. IF (cret .NE. 0) THEN
  1201. moterr ='mficlo'
  1202. interr(1) = cret
  1203. CALL ERREUR(873)
  1204. RETURN
  1205. ENDIF
  1206.  
  1207. IF (ISORTA .GT. 0) SEGSUP,ISORTA
  1208. SEGDES,MCOORD
  1209.  
  1210. END
  1211.  
  1212.  

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