Télécharger sormed.eso

Retour à la liste

Numérotation des lignes :

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

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