Télécharger sormed.eso

Retour à la liste

Numérotation des lignes :

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

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