Télécharger sormed.eso

Retour à la liste

Numérotation des lignes :

sormed
  1. C SORMED SOURCE OF166741 24/02/08 21:15:03 11811
  2.  
  3. C***********************************************************************
  4. C NOM : sormed.eso
  5. C DESCRIPTION : Sortie d'un maillage au FORMAT .med
  6. C***********************************************************************
  7. C HISTORIQUE : 21/12/2010 : CHAT : creation de la subroutine
  8. C HISTORIQUE : 07/06/2012 : JCARDO : l'argument MOT1 devient optionnel
  9. C + ajout de l'extension .med
  10. C HISTORIQUE : 04/11/2013 : BERTHINC : PASSAGE AU FORMAT 3.0 DE MED
  11. C HISTORIQUE : 16/10/2017 : RPAREDES : SORTIE CHPOINT,MCHAML,PASAPAS
  12. C HISTORIQUE : 09/10/2018 : BERTHINC : CALL ERREUR au lieu de WRITE
  13. C TAILLES parametriques et pas fixes
  14. C HISTORIQUE : 28/11/2018 : JCARDO : remplacement TMLCHA8 par TMLNOMS
  15. C + noms groupes en MED_NAME_SIZE
  16. C HISTORIQUE : 28/20/2019 : BERTHINC : PASSAGE AU FORMAT 4.0 DE MED
  17. C HISTORIQUE : 18/12/2019 : BERTHINC : Ne pas sortir les 'LX' & 'FLX' des 'CHPOINT'
  18. C Sortie plus facile des 'CHPOINTS' et 'MCHAML'
  19. C A l'aide de la SUBROUTINE smchp1
  20. C Sortie des TABLES quelconques pour les indices
  21. C de type 'MOT' pointant sur un MAILLAGE, MCHAML ou CHPOINT
  22. C HISTORIQUE : 20/10/2022 : OF : Ameliorations et corrections diverses
  23. C Ecriture des POLYGONEs (2D)
  24. C HISTORIQUE : 12/01/2024 : OF : Ameliorations diverses
  25. C HISTORIQUE : 24/01/2024 : OF : Menues ameliorations
  26. C HISTORIQUE : 31/01/2024 : OF : Menues modifications
  27. C HISTORIQUE : 08/02/2024 : OF : Correction numerotation locale profil
  28. C***********************************************************************
  29. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  30. C en cas de modification de ce sous-programme afin de faciliter
  31. C la maintenance !
  32. C***********************************************************************
  33. C APPELE PAR : operateur SORTir (prsort.eso)
  34. C***********************************************************************
  35. C ENTREES : aucune
  36. C SORTIES : aucune (sur fichier uniquement)
  37. C***********************************************************************
  38. C SYNTAXE (GIBIANE) :
  39. C
  40. C OPTI 'SORT' 'fichier.med';
  41. C SORT 'MED' OBJ1 OBJ2 ... OBJi ;
  42. C
  43. C avec OBJi = [ MAILi | CHPOi | TABi ]
  44. C
  45. C***********************************************************************
  46. SUBROUTINE SORMED
  47.  
  48. IMPLICIT INTEGER(I-N)
  49. IMPLICIT REAL*8 (A-H,O-Z)
  50.  
  51. -INC PPARAM
  52. -INC CCOPTIO
  53. -INC CCNOYAU
  54. -INC CCASSIS
  55. -INC CCGEOME
  56. -INC CCMED
  57.  
  58. -INC SMELEME
  59. -INC SMCOORD
  60. -INC SMCHPOI
  61. -INC SMCHAML
  62. -INC SMTABLE
  63. -INC SMMODEL
  64. -INC SMLENTI
  65. POINTEUR LPOLY.MLENTI
  66. -INC SMLMOTS
  67. -INC SMMED
  68.  
  69. -INC S4MED
  70.  
  71. EXTERNAL LONG
  72.  
  73. C Nom du fichier de sauvegarde au format 'MED' (fourni via OPTI SORT)
  74. CHARACTER*(LOCHAI) nomfid
  75.  
  76. C-----Definition des reels
  77. REAL*8 dt
  78. REAL*8 vcchmp
  79.  
  80. C-----Chaines de Caractere de longueur MED_SNAME_SIZE=16
  81. CHARACTER*(MED_SNAME_SIZE) dtunit
  82.  
  83. C-----Chaines de Caractere de longueur MED_NAME_SIZE=64
  84. CHARACTER*(MED_NAME_SIZE) name,fname,nomg,chaNSa
  85.  
  86. C-----Chaines de Caractere de longueur MED_LNAME_SIZE=80
  87. CHARACTER*(MED_LNAME_SIZE) gname
  88.  
  89. C-----Chaines de Caractere de longueur MED_COMMENT_SIZE=200
  90. CHARACTER*(MED_COMMENT_SIZE) desc
  91.  
  92. C ***** Declaration des segments
  93. SEGMENT SANAME
  94. CHARACTER*(MED_SNAME_SIZE) ANAME(IDIM)
  95. CHARACTER*(MED_SNAME_SIZE) AUNIT(IDIM)
  96. ENDSEGMENT
  97.  
  98. C-----Information sur les FAMILLES
  99. SEGMENT IJFAM
  100. INTEGER NFAM
  101. INTEGER IFAM(jf)
  102. INTEGER INUMF(jf)
  103. INTEGER INOGRO(jf)
  104. CHARACTER*(MED_NAME_SIZE) CNOMFA(jf)
  105. INTEGER IPROF(jf)
  106. C jf : Entier de dimensionnement
  107. C NFAM : Nombre de familles
  108. C IFAM : Objet MELEME (simple normalement)
  109. C INOGRO : pointeur sur un SEGMENT NOMGRO(Noms des groupes composes de cette famille)
  110. C CNOMFA : Nom de la famille
  111. C IPROF : pointeur sur un SEGMENT IPROFI pour definir le PROFIL
  112. ENDSEGMENT
  113.  
  114. C-----Contiendra les numeros des familles des elements pour chaque type (ITYPEL)
  115. SEGMENT INUMFA(nbelt)
  116.  
  117. C-----SEGMENT pour stocker les profils des familles (numero d'element local)
  118. SEGMENT IPROFI(nbelp)
  119.  
  120. C-----SEGMENT pour la numerotation locale (voir bdata.eso & CCGEOME pour NOMBR)
  121. SEGMENT INBTYP(3,NOMBR)
  122. C (1,.) : Nombre d'elements de ce type (MLENTI si POLYGONe)
  123. C (2,.) : Pointeur MELEME (MLENTI si POLYGONe)
  124. C (3,.) : Pointeur INUMFA
  125.  
  126. C-----NOGROU contient les noms des groupes qui incluent la famille
  127. SEGMENT NOMGRO
  128. INTEGER NOCO
  129. CHARACTER*(MED_LNAME_SIZE) NOGROU(kg)
  130. ENDSEGMENT
  131.  
  132. C-----Information sur les GROUPES
  133. SEGMENT IJGROU
  134. INTEGER ILENTI(nbgrou)
  135. INTEGER IPMAIL(nbgrou)
  136. CHARACTER*(MED_LNAME_SIZE) CNOMGR(nbgrou)
  137. C nbgrou : Nombre de groupes
  138. C ILENTI : pointeur LISTENTI des numeros de famille composant les groupes
  139. C IPMAIL : pointeur MELEME du groupe en question
  140. C CNOMGR : Noms des groupes
  141. ENDSEGMENT
  142.  
  143. SEGMENT ICPR8(nnic)
  144.  
  145. SEGMENT ICOO
  146. REAL*8 COO(IDIM,nnoe)
  147. ENDSEGMENT
  148.  
  149. C-----SEGMENT pour traiter les valeurs en INTEGER*4
  150. SEGMENT INT4(itaill)
  151.  
  152. C-----SEGMENT SREPER d'objets nommes et leur nom (INCLUDE SMMED)
  153. C SREPER ==> Repertorie les MAILLAGES nommes dans Cast3M
  154. C SREPE1 ==> Repertorie les POINTS nommes dans Cast3M
  155. C SREPE2 ==> Repertorie les MAILLAGES nommes dans des indices de TABLE
  156. C SREPE3 ==> Repertorie les POINTS nommes dans des indices de TABLE
  157.  
  158. C SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  159. SEGMENT SID
  160. C NBFUS : NOMBRE D'OBJETS A FUSIONNER
  161. C IPOINT : POINTEURS A FUSIONNER ou ENTIERS A FUSIONNER (cas particuler MAXI / MINI)
  162. C BVAL : LOGIQUES SUR LESQUELS ON FAIT UN ET/OU LOGIQUE
  163. C XVAL : REELS A FUSIONNER (cas particuler MAXI / MINI)
  164. C CVAL : MOTS A FUSIONNER (cas particuler MAXI / MINI)
  165. C CHATYP : MOT DONNANT LE TYPE D'OBJETS A FUSIONNER
  166. INTEGER IPOINT(NBFUS)
  167. LOGICAL BVAL (NBFUS)
  168. REAL*8 XVAL (NBFUS)
  169. CHARACTER*(IC1) CVAL(NBFUS)
  170. CHARACTER*8 CHATYP,CREATE
  171. ENDSEGMENT
  172.  
  173. SEGMENT ITLAC1(0)
  174. SEGMENT ITLACS(0)
  175.  
  176. CHARACTER*8 ctyp
  177. CHARACTER*4 cha4F
  178. CHARACTER*8 cha8b, cha8c, cha8d
  179. CHARACTER*(LONOM) cha24a
  180. CHARACTER*64 fobj
  181.  
  182. LOGICAL login, logre, log1, log2
  183.  
  184. CHARACTER*8 TYPOBJ, TYPMAI,TYPCHM,TYPMOD,TYPCHP,TYPMOT,
  185. & TYPTAB,TYPPOI
  186. DATA TYPMAI ,TYPCHM ,TYPMOD ,TYPCHP ,TYPMOT
  187. & / 'MAILLAGE','MCHAML ','MMODEL ','CHPOINT ','MOT ' /
  188. DATA TYPTAB ,TYPPOI
  189. & / 'TABLE ','POINT ' /
  190.  
  191. PARAMETER (NMOTC = 2)
  192. CHARACTER*(4) LMOTC(NMOTC)
  193. C- Sortie de tous les maillages (en particulier en cas de table)
  194. ccc DATA LMOTC / 'TOUS','TABM' /
  195. DATA LMOTC / 'NOID','TABM' /
  196. LOGICAL logall,logple
  197.  
  198. C **********************************************************************
  199. C DEBUT DES INSTRUCTIONS
  200. C **********************************************************************
  201. C-----Je bloque la sortie MED sur les ASSISTANTS (sans doute inutilement)
  202. IF (oothrd .NE. 0) THEN
  203. CALL ERREUR(915)
  204. RETURN
  205. ENDIF
  206.  
  207. SEGACT,MCOORD
  208.  
  209. C-----Initialisation
  210. TYPOBJ = ' '
  211.  
  212. INT4 = 0
  213. IJFAM = 0
  214. IJGROU = 0
  215. INUMFA = 0
  216. IPROFI = 0
  217. INBTYP = 0
  218.  
  219. SREPER = 0
  220. SREPE1 = 0
  221. SREPE2 = 0
  222. SREPE3 = 0
  223. NBREP1 = 0
  224. NBREP2 = 0
  225. NBREP3 = 0
  226. ITLAC1 = 0
  227.  
  228. IPT8 = 0
  229. ICPR8 = 0
  230. nnic = 0
  231. ICOO = 0
  232.  
  233. LISMAI = 0
  234. LISTBP = 0
  235. LISTBM = 0
  236. C-----Definition de la liste de CHPOINT & MCHAML
  237. LISCHP = 0
  238. LISCHA = 0
  239.  
  240. C-----Cas particulier des POLYGONEs (2D) : MED_POLYGON & ity=32
  241. C On ne considere que les polygones ayant de 1 a MED_MAXCPO cotes
  242. JG = 3 * (MED_MAXCPO + 1)
  243. SEGINI,LPOLY
  244. NEPOLY = 0
  245. NCPOLY = 0
  246.  
  247. C-----Creation du segment de travail INT4 (valeurs en INTEGER*4)
  248. C On initialise a NBPTS (>= nnoe) pour traitements lies aux noeuds
  249. C puis ajustement si necessaire lors du traitement des elements
  250. itaill = NBPTS
  251. SEGINI,INT4
  252.  
  253. C----- Nom par defaut :
  254. name ='$MESH_FROM_CAST3M$'
  255.  
  256. C----- Option(s) par defaut :
  257. logall = .TRUE.
  258. c#DEV logall = .FALSE. si option par defaut (pour avoir TRUE mot-cle TOUS
  259. c#DEV a definir dans MOTC au lieu de NOID) ---> Probleme actuellement
  260. c#DEV car on peut se retrouver sans maillage si on ne sort qu'un CHPO !
  261. logple = .FALSE.
  262.  
  263. C **********************************************************************
  264. C Analyse des objets envoyes a l'operateur
  265. C **********************************************************************
  266. SEGINI,ITLAC1
  267.  
  268. 1 CONTINUE
  269. INTEXT = 1
  270. ctyp = ' '
  271. cha24a = ' '
  272.  
  273. C---- Eventuels mot-cles :
  274. CALL LIRMOT(LMOTC,NMOTC,IMOTC,0)
  275. IF (IERR.NE.0) GOTO 9999
  276. c#DBG if (imotc.ne.0) write(ioimp,*) 'IMOTC =',IMOTC
  277. cccc IF (IMOTC.EQ.1) logall = .TRUE.
  278. IF (IMOTC.EQ.1) logall = .FALSE.
  279. IF (IMOTC.EQ.2) logple = .TRUE.
  280. IF (IMOTC.NE.0) GOTO 1
  281.  
  282. CALL QUETYP(ctyp, 0, iretou)
  283. IF (iretou .NE. 1) GOTO 100
  284. c#DBG write(ioimp,*) 'ctyp =',ctyp
  285.  
  286. CALL LIROBJ(ctyp, iret, 0, iretou)
  287.  
  288. C ***** On controle que le type est connu de Cast3M
  289. CALL TYPFIL(ctyp, k)
  290.  
  291. IF (k .LT. 0) THEN
  292. C----------On NE sait pas sortir un objet de ce type
  293. moterr = ctyp
  294. CALL ERREUR(242)
  295. GOTO 9999
  296. ENDIF
  297.  
  298. C-------Le type est ok
  299. CALL QUENOM(cha24a)
  300. ilon2 = LONG(cha24a)
  301. fname = ' '
  302.  
  303. IF (ctyp .EQ. TYPMAI) THEN
  304. C **************************************************************
  305. C * Sortie directe des MAILLAGE *
  306. C **************************************************************
  307. c#DBG write(ioimp,*) 'meleme lu =',iret
  308. CALL ACTOBJ(TYPMAI,iret,1)
  309. MELEME = iret
  310. jsous = MELEME.LISOUS(/1)
  311. IF (jsous.EQ.0) THEN
  312. IF (MEDEL(MELEME.ITYPEL) .EQ. MED_NONE) GOTO 10
  313. ELSE
  314. DO ii = 1, jsous
  315. IPT1 = MELEME.LISOUS(ii)
  316. IF (MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 10
  317. ENDDO
  318. ENDIF
  319. LISMAI = LISMAI + 1
  320. CALL AJOU(ITLAC1,iret)
  321. c#DBG write(ioimp,*) 'meleme conserve =',LISMAI,jsous+1
  322. 10 CONTINUE
  323.  
  324. ELSEIF (ctyp .EQ. TYPCHP) THEN
  325. C **************************************************************
  326. C * Sortie directe des CHPOINT *
  327. C **************************************************************
  328. c#DBG write(ioimp,*) 'chpoint lu =',iret
  329. CALL ACTOBJ(TYPCHP,iret,1)
  330. fname = cha24a
  331. i_z = MED_NO_DT
  332. xbid1 = MED_UNDEF_DT
  333. CALL smchp1(ITLAC1,iret,TYPCHP,LISCHP,fname,i_z,xbid1)
  334. IF (IERR .NE. 0) GOTO 9999
  335.  
  336. ELSEIF (ctyp .EQ. TYPCHM) THEN
  337. C **************************************************************
  338. C * Sortie directe des 'MCHAML' *
  339. C **************************************************************
  340. c#DBG write(ioimp,*) 'mchaml lu =',iret
  341. CALL ACTOBJ(TYPCHM,iret,1)
  342. fname = cha24a
  343. i_z = MED_NO_DT
  344. xbid1 = MED_UNDEF_DT
  345. CALL smchp1(ITLAC1,iret,TYPCHM,LISCHA,fname,i_z,xbid1)
  346. IF (IERR .NE. 0) GOTO 9999
  347.  
  348. ELSEIF (ctyp .EQ. TYPTAB) THEN
  349. C **************************************************************
  350. C * Sortie des 'TABLES' *
  351. C **************************************************************
  352. C-1----- On sort une TABLE
  353. MTABLE = iret
  354. TYPOBJ = ' '
  355. cha8d = ' '
  356. CALL ACCTAB(MTABLE,TYPMOT,ival1,xval1,'SOUSTYPE',login,iobin,
  357. & TYPOBJ,ival2,xval2,cha8d ,logre,iobre)
  358. IF (IERR .NE. 0) GOTO 9999
  359.  
  360. C-2----- On sort une TABLE de SOUSTYPE 'PASAPAS'
  361. IF (TYPOBJ.EQ.TYPMOT .AND. cha8d.EQ.'PASAPAS ') THEN
  362. LISTBP = LISTBP + 1
  363. cha8c = ' '
  364. CALL ACCTAB(MTABLE,TYPMOT,ival1,xval1,'MODELE',login,iobin,
  365. & TYPMOD,ival2,xval2,cha8c ,logre,iobre)
  366. IF (IERR .NE. 0) GOTO 9999
  367. MMODEL = iobre
  368. CALL ACTOBJ(TYPMOD,MMODEL,1)
  369. nsous = MMODEL.KMODEL(/1)
  370. n1 = nsous
  371. SEGINI,MMODE1
  372. n1 = 0
  373. DO isous = 1, nsous
  374. IMODEL = MMODEL.KMODEL(isous)
  375. IPT1 = IMODEL.IMAMOD
  376. IF (MEDEL(IPT1.ITYPEL) .NE. MED_NONE) THEN
  377. n1 = n1 + 1
  378. MMODE1.KMODEL(n1) = IMODEL
  379. CALL AJOU(ITLAC1,IPT1)
  380. ELSE
  381. write(ioimp,*) 'SORMED MMODEL ELEMENT NON PREVU'
  382. ENDIF
  383. ENDDO
  384. IF (n1.EQ.0) THEN
  385. write(ioimp,*) 'SORMED MMODEL VIDE'
  386. ENDIF
  387. IF (n1.NE.nsous) SEGADJ,MMODE1
  388.  
  389. cha8c = ' '
  390. CALL ACCTAB(MTABLE,TYPMOT,ival1,xval1,'TEMPS',login,iobin,
  391. & TYPTAB,ival2,xval2,cha8c ,logre,iobre)
  392. IF (IERR .NE. 0) GOTO 9999
  393. C Reactivation de la TABLE desactivee dans ACCTAB
  394. SEGACT,MTABLE
  395.  
  396. MTAB1 = iobre
  397. SEGACT,MTAB1
  398. nbtps = MTAB1.MLOTAB
  399.  
  400. C--------- Boucle sur tous les indices afin de chercher des champs a sortir
  401. nbind = MTABLE.MLOTAB
  402. DO ib=1,nbind
  403. C IPILOC peut avoir ete SEGDES
  404. if (nbesc.ne.0) SEGACT,IPILOC
  405. C----------- Recherche d'une table de CHPOINT ou MCHAML
  406. TYPOBJ = MTABLE.MTABTV(ib)
  407. IF (TYPOBJ .NE. TYPTAB) GOTO 90
  408. ip = MTABLE.MTABII(ib)
  409. nd = IPCHAR(ip)
  410. nf = IPCHAR(ip+1)
  411. IF ((nf-nd) .GT. MED_NAME_SIZE) THEN
  412. interr(1)= MED_NAME_SIZE
  413. moterr = ICHARA(nd:nd+MED_NAME_SIZE-1)
  414. CALL ERREUR(1096)
  415. GOTO 9999
  416. ENDIF
  417. chaNSa = ICHARA(nd:nf-1)
  418. ilon2 = LONG(chaNSa)
  419. fname = ' '
  420. fname(1:ilon2) = chaNSa(1:ilon2)
  421. c#DBG write(ioimp,*)'TABLE',ib,'INDICE //',chaNSa(1:ilon2),'\\'
  422.  
  423. IF ( (chaNSa(1:6) .EQ.'TEMPS ') .OR.
  424. & (chaNSa(1:10).EQ.'REACTIONS ') ) GOTO 90
  425.  
  426. C IF (chaNSa(1:11).EQ.'CHARGEMENT ') THEN
  427. CC Cas de l'indice CHARGEMENT
  428. C MCHARG = MTABLE.MTABIV(ib)
  429. C DO ic=1,nbtps
  430. C XTPS = MTAB1.RMTABV(ic)
  431. CC On invoque 'TIRE' au temps considere
  432. C CALL ECRCHA('TABL')
  433. C CALL ECRREE(XTPS)
  434. C CALL ECROBJ('CHARGEME',MCHARG)
  435. C CALL TIRE
  436. C CALL LIROBJ('TABLE',MTAB2,1,IRETOU)
  437. C SEGACT,MTAB2
  438. C ENDDO
  439. C GOTO 90
  440. C ENDIF
  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. TYPOBJ = MTAB2.MTABTV(1)
  449. IF (TYPOBJ.NE.TYPCHP .AND. TYPOBJ.NE.TYPCHM) 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.(TYPOBJ.NE.cha8c)) GOTO 90
  456. ENDDO
  457.  
  458. C------------ Boucle sur les indices SAUVES de la TABLE
  459. C ********************************************************
  460. C * INDICE DE TYPE 'CHPOINT' *
  461. C ********************************************************
  462. IF (TYPOBJ .EQ. TYPCHP) THEN
  463. DO ic=1,nbtps
  464. ndt = MTAB1.MTABII(ic)
  465. xtps = MTAB1.RMTABV(ic)
  466.  
  467. iret = MTAB2.MTABIV(ic)
  468. CALL ACTOBJ(TYPCHP,iret,1)
  469. IF (IERR .NE. 0) GOTO 9999
  470.  
  471. c#DBG write(ioimp,*) 'Appel a smchp1 CHPO fname=',fname,'='
  472. CALL smchp1(ITLAC1,iret,TYPCHP,LISCHP,fname,ndt,xtps)
  473. IF (IERR .NE. 0) GOTO 9999
  474. ENDDO
  475.  
  476. C ********************************************************
  477. C * INDICE DE TYPE 'MCHAML' *
  478. C ********************************************************
  479. ELSE IF (TYPOBJ .EQ. TYPCHM) THEN
  480. DO ic=1,nbtps
  481. ndt = MTAB1.MTABII(ic)
  482. xtps = MTAB1.RMTABV(ic)
  483.  
  484. iret = MTAB2.MTABIV(ic)
  485. CALL ACTOBJ(TYPCHM,iret,1)
  486. IF (IERR .NE. 0) GOTO 9999
  487. MCHELM = iret
  488. C Verification s'il faut passer aux noeuds
  489. ICHSUP = 0
  490. DO ii = 1,MCHELM.ICHAML(/1)
  491. ISUPP = MCHELM.INFCHE(ii,6)
  492. IF (ISUPP .GT. 2) THEN
  493. ICHSUP = 1
  494. GOTO 92
  495. ENDIF
  496. ENDDO
  497. 92 CONTINUE
  498. IF (ICHSUP .EQ. 1) THEN
  499. C Chgt de support aux Noeuds
  500. ISUPP = 1
  501. CALL REDUAF(MCHELM,MMODE1,MCHEL2,0,iret,kerre)
  502. IF (IRET .NE. 1) CALL ERREUR(kerre)
  503. IF (IERR .NE. 0) GOTO 9999
  504. CALL CHASUP(MMODE1,MCHEL2,MCHELM,iret,ISUPP)
  505. IF (IRET .NE. 0) THEN
  506. CALL ERREUR(iret)
  507. GOTO 9999
  508. ENDIF
  509. ENDIF
  510. iret = MCHELM
  511.  
  512. c#DBG write(ioimp,*) 'Appel a smchp1 CHAM fname=',fname,'='
  513. CALL smchp1(ITLAC1,iret,TYPCHM,LISCHA,fname,ndt,xtps)
  514. IF (IERR .NE. 0) GOTO 9999
  515. ENDDO
  516.  
  517. ENDIF
  518.  
  519. SEGDES,MTAB2
  520. 90 CONTINUE
  521. ENDDO
  522. C MTAB1 : TABLE des 'TEMPS'
  523. SEGDES,MTAB1
  524. SEGSUP,MMODE1
  525.  
  526. C-3----- On sort une TABLE quelconque
  527. C On ne veut que des indices de type MOT
  528. C Cas TABM = les indices doivent contenir que des MAILLAGE et POINT
  529. ELSE
  530.  
  531. log1 = .TRUE.
  532. name = ' '
  533. name = cha24a
  534.  
  535. SEGACT,MTABLE
  536. nbind = MTABLE.MLOTAB
  537. c#DBG write(ioimp,*) 'TABLE quelconque (60)',MTABLE,nbind
  538.  
  539. DO ib = 1, nbind
  540. IF (MTABTI(ib).NE.TYPMOT) THEN
  541. moterr = MTABTI(ib)
  542. CALL ERREUR(791)
  543. GOTO 9999
  544. ENDIF
  545. ENDDO
  546.  
  547. DO 60 ib = 1, nbind
  548.  
  549. C------------ Recherche d'une table de MAILLAGE et de POINT (pour l'option TABM)
  550. fname = ' '
  551. ip = MTABLE.MTABII(ib)
  552. cha8b = MTABLE.MTABTV(ib)
  553. iret = MTABLE.MTABIV(ib)
  554.  
  555. C IPILOC peut avoir ete SEGDES
  556. IF (NBESC.NE.0) SEGACT,IPILOC
  557. nd = IPCHAR(ip)
  558. nf = IPCHAR(ip+1)
  559. ilon2 = nf - nd
  560. IF (ilon2 .GT. MED_NAME_SIZE) THEN
  561. interr(1) = MED_NAME_SIZE
  562. moterr = ICHARA(nd:nd+MED_NAME_SIZE-1)
  563. CALL ERREUR(1096)
  564. GOTO 9999
  565. ENDIF
  566. chaNSa = ICHARA(nd:nf-1)
  567. ilon2 = LONG(chaNSa)
  568. fname = chaNSa
  569.  
  570. c#DBG write(ioimp,*) 'Indice ',ib,fname(1:ilon2),ilon2
  571. c#DBG write(ioimp,*) ' ',cha8b,iret
  572.  
  573. C* Cas particulier de l'indice SOUSTYPE :
  574. IF (fname(1:ilon2).EQ.'SOUSTYPE') THEN
  575. IF (cha8b .EQ. TYPMOT) THEN
  576. C IPILOC peut avoir ete SEGDES
  577. IF (NBESC.NE.0) SEGACT,IPILOC
  578. nd = IPCHAR(iret)
  579. nf = IPCHAR(iret+1)
  580. ilon2 = nf-nd
  581. IF (ilon2 .GT. MED_NAME_SIZE) THEN
  582. interr(1) = MED_NAME_SIZE
  583. moterr = ICHARA(nd:nd+MED_NAME_SIZE-1)
  584. CALL ERREUR(1096)
  585. GOTO 9999
  586. ENDIF
  587. chaNSa = ICHARA(nd:nf-1)
  588. ilon2 = LONG(chaNSa)
  589. name = ' '
  590. name(1:ilon2) = ChaNSa(1:ilon2)
  591. c#DBG write(ioimp,*) ' Nom du maillage par defaut : name = ',
  592. c#DBG & name(1:ilon2)
  593. ENDIF
  594. GOTO 60
  595. ENDIF
  596.  
  597. IF (cha8b .EQ. TYPPOI) THEN
  598. C ********************************************************
  599. C * Sortie des POINTS *
  600. C ********************************************************
  601. NBREP3 = NBREP3 + 1
  602. IF (SREPE3 .EQ. 0) THEN
  603. NBENT = nbind
  604. SEGINI,SREPE3
  605. ELSE
  606. IF (NBREP3 .GT. SREPE3.IREPER(/1)) THEN
  607. NBENT = SREPE3.IREPER(/1) + nbind
  608. SEGADJ,SREPE3
  609. ENDIF
  610. ENDIF
  611. INO3 = iret
  612. SREPE3.IREPER(NBREP3) = INO3
  613. SREPE3.CREPER(NBREP3) = ' '
  614. SREPE3.CREPER(NBREP3) = chaNSa(1:ilon2)
  615. c#DBG write(ioimp,*) ' POINT',NBREP3,ChaNSa,'NOEUD',INO3
  616.  
  617. ELSEIF (cha8b .EQ. TYPMAI) THEN
  618. C ********************************************************
  619. C * Sortie des MAILLAGE *
  620. C ********************************************************
  621. CALL ACTOBJ(TYPMAI,iret,1)
  622. MELEME = iret
  623. jsous = MELEME.LISOUS(/1)
  624. IF (jsous.EQ.0) THEN
  625. IF (MEDEL(MELEME.ITYPEL) .EQ. MED_NONE) GOTO 60
  626. ELSE
  627. DO ii = 1, jsous
  628. IPT1 = MELEME.LISOUS(ii)
  629. IF (MEDEL(IPT1.ITYPEL) .EQ. MED_NONE) GOTO 60
  630. ENDDO
  631. ENDIF
  632. CALL AJOU(ITLAC1,iret)
  633.  
  634. NBREP2=NBREP2 + 1
  635. IF(SREPE2 .EQ. 0)THEN
  636. NBENT = nbind
  637. SEGINI,SREPE2
  638. ELSE
  639. IF(NBREP2 .GT. SREPE2.IREPER(/1))THEN
  640. NBENT =SREPE2.IREPER(/1) + nbind
  641. SEGADJ,SREPE2
  642. ENDIF
  643. ENDIF
  644. SREPE2.IREPER(NBREP2)=MELEME
  645. SREPE2.CREPER(NBREP2)=' '
  646. SREPE2.CREPER(NBREP2)=chaNSa(1:ilon2)
  647. c#DBG write(ioimp,*) ' MAILLAGE',NBREP2,MELEME,ChaNSA
  648.  
  649. ELSEIF (TYPOBJ .EQ. TYPCHP) THEN
  650. C ********************************************************
  651. C * Sortie des CHPOINT *
  652. C ********************************************************
  653. CALL ACTOBJ(TYPCHP,iret,1)
  654. IF (IERR .NE. 0) GOTO 9999
  655.  
  656. CALL smchp1(ITLAC1,iret,TYPCHP,LISCHP,fname,ndt,xtps)
  657. IF (IERR .NE. 0) GOTO 9999
  658. log1 = .FALSE.
  659.  
  660. ELSEIF (TYPOBJ .EQ. TYPCHM) THEN
  661. C ********************************************************
  662. C * Sortie des MCHAML *
  663. C ********************************************************
  664. CALL ACTOBJ(TYPCHM,iret,1)
  665. IF (IERR .NE. 0) GOTO 9999
  666.  
  667. MCHELM = iret
  668. C Champ aux noeuds, aux gravite, constant ?
  669. DO ii = 1,MCHELM.ICHAML(/1)
  670. ISUPP = MCHELM.INFCHE(ii,6)
  671. IF (ISUPP .GT. 2) THEN
  672. write(ioimp,*) 'Support incorrect !'
  673. CALL ERREUR(21)
  674. GOTO 9999
  675. ENDIF
  676. ENDDO
  677.  
  678. CALL smchp1(ITLAC1,iret,TYPCHM,LISCHA,fname,ndt,xtps)
  679. IF (IERR .NE. 0) GOTO 9999
  680. log1 = .FALSE.
  681.  
  682. ELSE
  683. C Indice non sorti actuellement
  684. moterr = ' MAILLAGE'
  685. CALL ERREUR(800)
  686. GOTO 9999
  687. ENDIF
  688.  
  689. IF (NBESC.NE.0) SEGDES,IPILOC
  690. 60 CONTINUE
  691. SEGDES,MTABLE
  692. IF (log1) THEN
  693. LISTBM = LISTBM + 1
  694. ELSE
  695. LISTBP = LISTBP + 1
  696. END IF
  697. ENDIF
  698.  
  699. C---------On NE sait pas sortir ce type d'objet
  700. ELSE
  701. moterr = ctyp
  702. CALL ERREUR(242)
  703. GOTO 9999
  704. ENDIF
  705.  
  706. GOTO 1
  707.  
  708. C-----On a explore toutes les demandes
  709. 100 CONTINUE
  710. if (nbesc.ne.0) SEGDES,IPILOC
  711.  
  712. C-----Cas particuliers :
  713. log1 = (LISMAI.NE.0) .OR. (LISCHP.NE.0) .OR. (LISCHA.NE.0)
  714. & .OR. (LISTBP.NE.0)
  715. log2 = (LISTBM.EQ.0)
  716. IF (log1 .AND. log2) logple = .FALSE.
  717. IF ((.NOT.log1) .AND. (.NOT.log2)) logple = .TRUE.
  718. IF (logple) THEN
  719. IF (log1) THEN
  720. write(ioimp,*) 'Seules des tables contenant des MAILLAGE & ',
  721. & 'POINT sont possibles avec l option TABM'
  722. CALL ERREUR(19)
  723. GOTO 9999
  724. END IF
  725. IF (log2) THEN
  726. write(ioimp,*) 'Pas de table a sortir !'
  727. CALL ERREUR(21)
  728. GOTO 9999
  729. END IF
  730. c#DBG IF (logall) THEN
  731. c#DBG write(ioimp,*) 'Option "TOUS" desactivee'
  732. c#DBG END IF
  733. logall = .FALSE.
  734. c#DBG IF (SREPE2.LE.0 .AND. SREPE3.LE.0) THEN
  735. c#DBG write(ioimp,*) 'DBG - SREPE2 et SREPE3 non definis !'
  736. c#DBG CALL ERREUR(5)
  737. c#DBG END IF
  738. END IF
  739.  
  740. C **********************************************************************
  741. C Union des MELEME ELEMENTAIRES
  742. C **********************************************************************
  743. c#DBG write(ioimp,*)
  744. NBFUS = ITLAC1(/1)
  745. c#DBG write(ioimp,*) 'NBFUS = ',NBFUS
  746. IF (NBFUS .EQ. 0) THEN
  747. C-------Rien a sortir...
  748. CALL ERREUR(-365)
  749. GOTO 9999
  750. ELSEIF (NBFUS .EQ. 1) THEN
  751. IPT8 = ITLAC1(1)
  752. ELSEIF (NBFUS .GT. 1) THEN
  753. ITLACS = 0
  754. SEGINI,ITLACS
  755. DO ii = 1, NBFUS
  756. MELEME = ITLAC1(ii)
  757. jsous = MELEME.LISOUS(/1)
  758. IF (jsous.EQ.0) THEN
  759. c#DBG write(ioimp,*) 'ITLACS ajout S',ii,MELEME
  760. CALL AJOU(ITLACS,MELEME)
  761. ELSE
  762. c#DBG write(ioimp,*) 'ITLACS ajout C',ii,MELEME
  763. DO j = 1, jsous
  764. iret = MELEME.LISOUS(j)
  765. c#DBG write(ioimp,*) 'ITLACS ajout C',ii,j,iret
  766. CALL AJOU(ITLACS,iret)
  767. ENDDO
  768. ENDIF
  769. ENDDO
  770. NBFUS = ITLACS(/1)
  771. IC1=0
  772. SEGINI,SID
  773. SID.CREATE='SORT MED'
  774. SID.CHATYP=TYPMAI
  775. DO ii = 1, NBFUS
  776. SID.IPOINT(ii)=ITLACS(ii)
  777. ENDDO
  778. c#DBG write(ioimp,*) 'ITLACS FUSION',NBFUS
  779. log1 = .FALSE.
  780. xbid1 = 0.D0
  781. CALL FUNOBJ(SID,IPT8,xbid1,log1)
  782. SEGSUP,SID
  783. SEGSUP,ITLACS
  784. c** CALL AJOU(ITLAC1,IPT8)
  785. CALL ACTOBJ(TYPMAI,IPT8,1)
  786. ELSE
  787. CALL ERREUR(5)
  788. GOTO 9999
  789. ENDIF
  790. c#DBG write(ioimp,*) 'UNION',NBFUS,IPT8
  791.  
  792. C **********************************************************************
  793. C REPERAGE DES NOEUDS A SAUVER
  794. C **********************************************************************
  795. nnoe = 0
  796.  
  797. nnic = NBPTS
  798. SEGINI,ICPR8
  799. imax = 0
  800. imin = NBPTS + 1
  801.  
  802. IPT1 = IPT8
  803. jsous = IPT8.LISOUS(/1)
  804. DO ii = 1, MAX(jsous,1)
  805. IF (jsous.GE.1) IPT1 = IPT8.LISOUS(ii)
  806. DO j = 1, IPT1.NUM(/2)
  807. DO i = 1, IPT1.NUM(/1)
  808. inoe = IPT1.NUM(i,j)
  809. IF (ICPR8(inoe).LE.0) THEN
  810. nnoe = nnoe + 1
  811. ICPR8(inoe) = nnoe
  812. imin = MIN(imin,inoe)
  813. imax = MAX(imax,inoe)
  814. END IF
  815. END DO
  816. END DO
  817. END DO
  818. c#DBG write(ioimp,*) 'NNOE IPT8',nnoe,imin,imax,NBPTS
  819. IF (NBREP3.GT.0) THEN
  820. DO i = 1, NBREP3
  821. inoe = SREPE3.IREPER(i)
  822. IF (ICPR8(inoe).LE.0) THEN
  823. nnoe = nnoe + 1
  824. ICPR8(inoe) = nnoe
  825. imin = MIN(imin,inoe)
  826. imax = MAX(imax,inoe)
  827. END IF
  828. END DO
  829. c#DBG write(ioimp,*)
  830. c#DBG write(ioimp,*) 'NNOE IPT8+MPOI3',nnoe,imin,imax,NBPTS
  831. END IF
  832.  
  833. C **********************************************************************
  834. C * En 2D on repere s'il y a des POLYGONEs (itypel=32) dans IPT8
  835. C * Attention : NEPOLY et NCPOLY sont surdimensionnes !
  836. C **********************************************************************
  837. jsous = IPT8.LISOUS(/1)
  838. IPT1 = IPT8
  839. DO ii = 1, MAX(1,jsous)
  840. IF (jsous.GE.1) IPT1 = IPT8.LISOUS(ii)
  841. IF (IPT1.ITYPEL.EQ.32) THEN
  842. if (nbnn.gt.MED_MAXCPO) then
  843. write(ioimp,*) 'MAILLAGE ',IPT1,' : POLYGON edges ',nbnn,
  844. & ' > ',MED_MAXCPO
  845. call erreur(5)
  846. goto 9999
  847. end if
  848. nbnn = IPT1.NUM(/1)
  849. nbelem = IPT1.NUM(/2)
  850. NEPOLY = NEPOLY + nbelem
  851. NCPOLY = NCPOLY + (nbelem*nbnn)
  852. j = 3*nbnn-2
  853. LPOLY.LECT(j) = LPOLY.LECT(j) + nbelem
  854. END IF
  855. END DO
  856. IF (NEPOLY.GT.0) THEN
  857. iel = 0
  858. ino = 0
  859. j = 3
  860. DO ii = 1, MED_MAXCPO
  861. LPOLY.LECT(j-1) = iel
  862. LPOLY.LECT(j ) = ino
  863. nbelem = LPOLY.LECT(j-2)
  864. iel = iel + nbelem
  865. ino = ino + (nbelem * ii)
  866. j = j + 3
  867. END DO
  868. LPOLY.LECT(j-1) = iel
  869. LPOLY.LECT(j ) = ino
  870. c#DBG jjjcpo = MIN(11,MED_MAXCPO)
  871. c#DBG write(ioimp,*) 'POLYGONES'
  872. c#DBG write(ioimp,*) (ii,LPOLY.LECT(3*ii-2),ii=1,jjjcpo)
  873. c#DBG write(ioimp,*) 'NEPOLY =',NEPOLY,LPOLY.LECT(3*MED_MAXCPO+2)
  874. c#DBG write(ioimp,*) (ii,LPOLY.LECT(3*ii-1),ii=1,jjjcpo+1)
  875. c#DBG write(ioimp,*) 'NCPOLY =',NCPOLY,LPOLY.LECT(3*MED_MAXCPO+3)
  876. c#DBG write(ioimp,*) (ii,LPOLY.LECT(3*ii ),ii=1,jjjcpo+1)
  877. END IF
  878.  
  879. C **********************************************************************
  880. C Creation des GROUPES
  881. C **********************************************************************
  882. c#DBG write(ioimp,*)
  883. IF (logall) THEN
  884. C Liste des MELEME nommes inclus strictement dans IPT8
  885. CALL NOEINC(ICPR8,TYPMAI,SREPER)
  886. NBNOM = SREPER.IREPER(/1)
  887. c#DBG write(ioimp,*) 'MELEME nommes inclus dans IPT8'
  888. c#DBG write(ioimp,*) 'SREPER',SREPER,NBNOM
  889. c#DBG DO ii = 1, NBNOM
  890. c#DBG write(ioimp,*) ' SREP',ii,NBNOM,IREPER(ii),CREPER(ii)
  891. c#DBG ENDDO
  892. ELSE
  893. NBENT = 0
  894. SEGINI,SREPER
  895. NBNOM = NBENT
  896. c#DBG write(ioimp,*) 'On ne prend pas les MELEME nommes'
  897. END IF
  898.  
  899. C Ajout des MELEME nommes par des indices de TABLES QUELCONQUES
  900. IF (SREPE2 .GT. 0) THEN
  901. NBENT = NBNOM + NBREP2
  902. SEGADJ,SREPER
  903. DO ii = 1, NBREP2
  904. IPT1 = SREPE2.IREPER(ii)
  905. C 2 objets differents pour le meme nom (objet nomme / indice table) ==> interdit
  906. CALL PLACE(SREPER.CREPER(1),NBNOM,IMOT,SREPE2.CREPER(ii))
  907. IF (IMOT .NE. 0) THEN
  908. IF (IPT1 .NE. SREPER.IREPER(IMOT)) THEN
  909. write(ioimp,*) 'objets differents pour le meme nom ',
  910. & '(objet nomme / indice table) ==> interdit'
  911. CALL ERREUR(21)
  912. GOTO 9999
  913. ENDIF
  914. ENDIF
  915. c* CALL PLACE2(SREPER.IREPER(1),NBNOM,IDANS,IPT1)
  916. c* IF (IDANS.EQ.0) THEN
  917. c* Un meme maillage peut etre pointe plusieurs fois (avec noms et indices differents)
  918. NBNOM = NBNOM + 1
  919. SREPER.IREPER(NBNOM) = IPT1
  920. SREPER.CREPER(NBNOM) = SREPE2.CREPER(ii)
  921. c* END IF
  922. ENDDO
  923. c#DBG write(ioimp,*) 'SREPER+2',NBNOM,NBREP2
  924. c#DBG DO ii = 1, NBNOM
  925. c#DBG write(ioimp,*) ' SREP',ii,NBNOM,IREPER(ii),CREPER(ii)
  926. c#DBG ENDDO
  927. ENDIF
  928.  
  929. C Ajout de tous les MELEME pointes dans ITLAC1 si demande !
  930. IF (logall) THEN
  931. NBMAIL = ITLAC1(/1)
  932. C Ceux pas nommes --> nom base sur num de pointeur
  933. NBENT = NBNOM + NBMAIL
  934. SEGADJ,SREPER
  935. C Determination du FORMAT automatique
  936. IFORMA = INT(LOG10(REAL(NBENT))) + 1
  937. IF (IFORMA.LT.0 .OR. IFORMA.GE.9) THEN
  938. CALL ERREUR(1094)
  939. GOTO 9999
  940. ENDIF
  941. cha8d = '(I8.8) '
  942. IF (IFORMA.LE.6) cha8d = '(I6.6) '
  943. IF (IFORMA.LE.3) cha8d = '(I3.3) '
  944.  
  945. DO ii = 1, NBMAIL
  946. IPT1 = ITLAC1(ii)
  947. CALL PLACE2(SREPER.IREPER(1),NBNOM,IDANS,IPT1)
  948. c#DBG if (idans .gt. 0)
  949. c#DBG & write(ioimp,*) ' ',ii,NBMAIL,IPT1,' IDANS=',IDANS,NBNOM,NBENT
  950. c#DBG & ,SREPER.CREPER(IDANS)
  951. IF (IDANS .GT. 0) GOTO 20
  952. C MAILLAGE A Ajouter
  953. NBNOM = NBNOM+1
  954. C Les pointeurs negatifs serviront a ne pas creer de FAMILLE supplementaire
  955. SREPER.IREPER(NBNOM) = -IPT1
  956. cha8c = ' '
  957. WRITE(cha8c,cha8d(1:6)) NBNOM
  958. SREPER.CREPER(NBNOM) = '$MAIL$_'//cha8c
  959. c#DBG write(ioimp,*) ' ',ii,NBMAIL,IPT1,' <0 ',NBNOM,
  960. c#DBG & SREPER.CREPER(NBNOM)
  961. ilon2 = NBNOM - 1
  962. CALL PLACE(SREPER.CREPER(1),ilon2,IMOT,SREPER.CREPER(NBNOM))
  963. IF (IMOT .GT. 0) THEN
  964. CALL ERREUR(21)
  965. GOTO 9999
  966. END IF
  967. 20 CONTINUE
  968. END DO
  969. IF (NBENT .NE. NBNOM) THEN
  970. NBENT = NBNOM
  971. SEGADJ,SREPER
  972. ENDIF
  973. c#DBG write(ioimp,*)
  974. c#DBG write(ioimp,*) 'SREPER',NBNOM,NBREP2,NBMAIL
  975. c#DBG DO ii = 1, NBNOM
  976. c#DBG write(ioimp,*) ' SREP',ii,NBNOM,IREPER(ii),
  977. c#DBG & CREPER(ii)(1:LONG(CREPER(ii)))
  978. c#DBG ENDDO
  979. END IF
  980.  
  981. C **********************************************************************
  982. c#DBG write(ioimp,*)
  983. IF (logall) THEN
  984. C Reperage des POINT nommes strictement inclus dans ICPR8
  985. CALL NOEINC(ICPR8,TYPPOI,SREPE1)
  986. NBREP1 = SREPE1.IREPER(/1)
  987. DO ii = 1, NBREP1
  988. SREPE1.IREPER(ii) = ICPR8(SREPE1.IREPER(ii))
  989. END DO
  990. c#DBG write(ioimp,*) 'POINTS nommes inclus dans ICPR8'
  991. c#DBG write(ioimp,*) 'SREPE1',SREPE1,NBREP1
  992. c#DBG DO ii = 1, NBREP1
  993. c#DBG write(ioimp,*) ' SREP1',ii,NBREP1,SREPE1.IREPER(ii),
  994. c#DBG & SREPE1.CREPER(ii)(1:LONG(SREPE1.CREPER(ii)))
  995. c#DBG END DO
  996. ELSE
  997. NBENT = 0
  998. SEGINI,SREPE1
  999. NBREP1 = NBENT
  1000. c#DBG write(ioimp,*) 'On ne prend pas les POINTS nommes'
  1001. END IF
  1002.  
  1003. C Ajout des POINTS nommes par des indices de TABLES QUELCONQUES
  1004. C Test equivalent : IF (SREPE3 .GT. 0) THEN
  1005. IF (NBREP3.GT.0) THEN
  1006. NBENT = NBREP1 + NBREP3
  1007. SEGADJ,SREPE1
  1008. NBNOM1 = NBREP1
  1009. DO ii = 1, NBREP3
  1010. IPT3 = SREPE3.IREPER(ii)
  1011. INO3 = ICPR8(IPT3)
  1012. c#DBG write(ioimp,*) 'SREPE3',ii,NBREP3,IPT3,INO3
  1013. CALL PLACE(SREPE1.CREPER(1),NBNOM1,IMOT,SREPE3.CREPER(ii))
  1014. C 2 points differents pour le meme nom ==> interdit
  1015. IF (IMOT .NE. 0) THEN
  1016. IF (INO3 .NE. SREPE1.IREPER(IMOT)) THEN
  1017. write(ioimp,*) 'points differents pour le meme nom ',
  1018. & '(objet nomme / indice table) ==> interdit'
  1019. CALL ERREUR(21)
  1020. GOTO 9999
  1021. ENDIF
  1022. ENDIF
  1023. c* CALL PLACE2(SREPE1.IREPER(1),NBNOM1,IDANS,INO3)
  1024. c* IF (IDANS.LE.0) THEN
  1025. c* Un meme point peut etre reference plusieurs fois (avec noms et indices differents)
  1026. NBNOM1 = NBNOM1 + 1
  1027. SREPE1.IREPER(NBNOM1) = INO3
  1028. SREPE1.CREPER(NBNOM1) = SREPE3.CREPER(ii)
  1029. c#DBG write(ioimp,*) 'Ajout SREPE1',ii,NBREP3,NBNOM1,IPT3,INO3,
  1030. c#DBG & SREPE3.CREPER(ii)
  1031. c* END IF
  1032. END DO
  1033. IF (NBENT.NE.NBNOM1) THEN
  1034. NBENT = NBNOM1
  1035. SEGADJ,SREPE1
  1036. ENDIF
  1037. c#DBG write(ioimp,*)
  1038. c#DBG write(ioimp,*) 'SREPE1+3',NBNOM1
  1039. c#DBG do ii = 1, NBNOM1
  1040. c#DBG write(ioimp,*) ' SREP1',ii,NBNOM1,SREPE1.IREPER(ii),
  1041. c#DBG & SREPE1.CREPER(ii)
  1042. c#DBG enddo
  1043. ENDIF
  1044. NBREP1 = SREPE1.IREPER(/1)
  1045.  
  1046. C Initialisation du code de retour :
  1047. mcret = 0
  1048.  
  1049. C **********************************************************************
  1050. C Creation/ouverture d'un fichier MED 4.*
  1051. C **********************************************************************
  1052. nomfid = ' '
  1053. C Recuperation du nom stocke par 'OPTI' 'SORT'
  1054. INQUIRE(UNIT = ioper, NAME = nomfid )
  1055. CLOSE (UNIT = ioper, STATUS ='DELETE')
  1056.  
  1057. ilon2 = LONG(nomfid)
  1058. macces = MED_ACC_CREAT
  1059. CALL mfiope(mfid, nomfid(1:ilon2), macces, mcret)
  1060. IF (mcret .NE. 0) THEN
  1061. moterr = 'sormed / mfiope '//nomfid(1:ilon2)
  1062. interr(1)= mcret
  1063. CALL ERREUR(873)
  1064. GOTO 9999
  1065. ENDIF
  1066.  
  1067. C **********************************************************************
  1068. C Creation d'un MAILLAGE dans MED 4.*
  1069. C **********************************************************************
  1070. C-----Creation du repere cartesien
  1071. SEGINI,SANAME
  1072. IF (IDIM .EQ. 1)THEN
  1073. SANAME.ANAME(1)='X'
  1074. SANAME.AUNIT(1)='NO_UNIT'
  1075. ELSEIF(IDIM .EQ. 2)THEN
  1076. SANAME.ANAME(1)='X'
  1077. SANAME.ANAME(2)='Y'
  1078. SANAME.AUNIT(1)='NO_UNIT'
  1079. SANAME.AUNIT(2)='NO_UNIT'
  1080. ELSEIF(IDIM .EQ. 3)THEN
  1081. SANAME.ANAME(1)='X'
  1082. SANAME.ANAME(2)='Y'
  1083. SANAME.ANAME(3)='Z'
  1084. SANAME.AUNIT(1)='NO_UNIT'
  1085. SANAME.AUNIT(2)='NO_UNIT'
  1086. SANAME.AUNIT(3)='NO_UNIT'
  1087. ELSE
  1088. interr(1)=IDIM
  1089. CALL ERREUR(709)
  1090. CALL ERREUR(832)
  1091. GOTO 9998
  1092. ENDIF
  1093.  
  1094. c#DBG ilon2 = long(name)
  1095. c#DBG write(ioimp,*)
  1096. c#DBG write(ioimp,*) 'NAME ='//name(1:ilon2)//'='
  1097.  
  1098. msdim = IDIM
  1099. mmdim = IDIM
  1100. mmtype = MED_UNSTRUCTURED_MESH
  1101. desc = 'MAILLAGE MED sorti par Cast3M'
  1102. dtunit = 'NO_UNIT'
  1103. mstype = MED_SORT_DTIT
  1104. matype = MED_CARTESIAN
  1105.  
  1106. CALL mmhcre(mfid, name, msdim, mmdim, mmtype, desc, dtunit,
  1107. & mstype, matype, SANAME.ANAME, SANAME.AUNIT, mcret)
  1108. IF (mcret .NE. 0) THEN
  1109. moterr = 'sormed / mmhcre'
  1110. interr(1)= mcret
  1111. CALL ERREUR(873)
  1112. GOTO 9998
  1113. ENDIF
  1114.  
  1115. C **********************************************************************
  1116. C Ecriture des coordonnees des noeuds compris entre 1 et nnoe
  1117. C **********************************************************************
  1118. SEGINI,ICOO
  1119. ii = 0
  1120. idimp1 = IDIM+1
  1121. DO inoe = 1, NBPTS
  1122. jnoe = ICPR8(inoe)
  1123. IF (jnoe.GT.0) THEN
  1124. ival1 = (inoe-1)*idimp1
  1125. DO j = 1, IDIM
  1126. icoo.COO(j,jnoe) = mcoord.XCOOR(ival1+j)
  1127. END DO
  1128. ii = ii + 1
  1129. END IF
  1130. END DO
  1131. IF (ii.NE.nnoe) write(ioimp,*) 'PBM II != NNOE',ii,nnoe
  1132.  
  1133. numdt = MED_NO_DT
  1134. numit = MED_NO_IT
  1135. dt = MED_UNDEF_DT
  1136. mswm = MED_FULL_INTERLACE
  1137. n4 = nnoe
  1138.  
  1139. CALL mmhcow(mfid, name, numdt, numit, dt, mswm, n4,
  1140. & icoo.COO, mcret)
  1141. IF (mcret .NE. 0) THEN
  1142. moterr = 'sormed / mmhcow'
  1143. interr(1)= mcret
  1144. CALL ERREUR(873)
  1145. GOTO 9998
  1146. ENDIF
  1147.  
  1148. C **********************************************************************
  1149. C Ecriture de la numerotation globale des noeuds (GLobal ID = 1 a nnoe)
  1150. C **********************************************************************
  1151. numdt = MED_NO_DT
  1152. numit = MED_NO_IT
  1153. metype = MED_NODE
  1154. mgtype = MED_NONE
  1155.  
  1156. CALL mhenw4(mfid, name, numdt, numit, metype, mgtype, nnoe,
  1157. & INT4(1), mcret)
  1158. IF (mcret .NE. 0) THEN
  1159. moterr = 'sormed / mhenw4'
  1160. interr(1) = mcret
  1161. CALL ERREUR(873)
  1162. GOTO 9998
  1163. ENDIF
  1164.  
  1165. C **********************************************************************
  1166. C Creation des FAMILLES
  1167. C **********************************************************************
  1168. C +-----------------------------------------------------------------+
  1169. C |FAMILLE 0 de nom 'FAMILLE_ZERO' (OBLIGATOIRE) : comporte 0 groupe
  1170. C +-----------------------------------------------------------------+
  1171. fname = 'FAMILLE_ZERO'
  1172. mfnum = 0
  1173. n4 = 0
  1174. gname = ' '
  1175. CALL mfacre(mfid, name, fname, mfnum, n4, gname, mcret)
  1176. IF (mcret .NE. 0) THEN
  1177. moterr = 'sormed / mfacre'
  1178. interr(1) = mcret
  1179. CALL ERREUR(873)
  1180. GOTO 9998
  1181. ENDIF
  1182.  
  1183. C +-----------------------------------------------------------------+
  1184. C |FAMILLE des POINTS nommes : Numerotation positive
  1185. C +-----------------------------------------------------------------+
  1186. C Reperage des POINT nommes
  1187. IF (NBREP1 .NE. 0) THEN
  1188. nbelt = nnoe
  1189. SEGINI,INUMFA
  1190.  
  1191. jg = NBREP1
  1192. SEGINI,MLENTI
  1193.  
  1194. indfam = 0
  1195. DO indice = 1,NBREP1
  1196. iob = SREPE1.IREPER(indice)
  1197. c#DBG write(ioimp,*) ' B110',indice,NBREP1,iob,INUMFA(iob)
  1198. IF (INUMFA(iob) .EQ. 0) THEN
  1199. indfam = indfam + 1
  1200. INUMFA(iob) = indfam
  1201. c#DBG write(ioimp,*) ' nouvelle famille',indice,iob,indfam
  1202. kg = NBREP1
  1203. SEGINI,NOMGRO
  1204. NOMGRO.NOCO = 0
  1205. MLENTI.LECT(indfam) = NOMGRO
  1206. ENDIF
  1207. ii = INUMFA(iob)
  1208. NOMGRO = MLENTI.LECT(ii)
  1209. kg = NOMGRO.NOCO + 1
  1210. NOMGRO.NOCO = kg
  1211. NOMGRO.NOGROU(kg) = SREPE1.CREPER(indice)
  1212. c#DBG write(ioimp,*) ' nouveau groupe',kg,NOMGRO.NOGROU(kg),
  1213. c#DBG & 'famille',ii
  1214. END DO
  1215.  
  1216. C ***** Ecriture des numeros de famille des POINTS nommes dans Cast3M
  1217. numdt = MED_NO_DT
  1218. numit = MED_NO_IT
  1219. metype = MED_NODE
  1220. mgtype = MED_NONE
  1221.  
  1222. CALL mhfnw4(mfid, name, numdt, numit, metype, mgtype, nnoe,
  1223. & INUMFA(1), INT4(1), mcret)
  1224. IF (mcret .NE. 0) THEN
  1225. moterr = 'sormed / mhfnw4'
  1226. interr(1) = mcret
  1227. CALL ERREUR(873)
  1228. GOTO 9998
  1229. ENDIF
  1230.  
  1231. C Determination du FORMAT automatique
  1232. IF (indfam.GT.0) THEN
  1233. IFORMA = INT(LOG10(REAL(indfam))) + 1
  1234. IF (IFORMA.LT.1 .OR. IFORMA.GE.9) THEN
  1235. CALL ERREUR(1094)
  1236. GOTO 9998
  1237. ENDIF
  1238. cha4F ='(I )'
  1239. WRITE(cha4F(3:3),FMT='(I1)') IFORMA
  1240. ilong = 3+IFORMA
  1241. END IF
  1242.  
  1243. fobj = 'FAP'
  1244. DO ii = 1, indfam
  1245.  
  1246. WRITE(fobj(4:ilong),FMT= cha4F) ii
  1247. C ***** Creation des groupes de POINTS nommes dans Cast3M
  1248. fname = fobj(1:ilong)
  1249. mfnum = ii
  1250. NOMGRO = MLENTI.LECT(ii)
  1251. n4 = NOMGRO.NOCO
  1252.  
  1253. CALL mfacre(mfid,name, fname, mfnum, n4, NOMGRO.NOGROU, mcret)
  1254. IF (mcret .NE. 0) THEN
  1255. moterr ='sormed / mfacre'
  1256. interr(1) = mcret
  1257. CALL ERREUR(873)
  1258. GOTO 9998
  1259. ENDIF
  1260. ENDDO
  1261.  
  1262. ENDIF
  1263.  
  1264. C +-----------------------------------------------------------------+
  1265. C |FAMILLE d''elements : Numerotation negative
  1266. C +-----------------------------------------------------------------+
  1267. nbgrou = SREPER.IREPER(/1)
  1268. c#DBG write(ioimp,*) 'FAMILLE ELEMENTS : nbgrou=',nbgrou
  1269. jf = 20
  1270. SEGINI,IJGROU,IJFAM
  1271. NFA = 0
  1272. DO ii = 1, nbgrou
  1273. c* log1 = SREPER.IREPER(ii) .LT. 0
  1274. IPT1 = ABS(SREPER.IREPER(ii))
  1275. nomg = SREPER.CREPER(ii)
  1276.  
  1277. IJGROU.IPMAIL(ii)=IPT1
  1278. IJGROU.CNOMGR(ii)=nomg
  1279.  
  1280. NBSOUS = IPT1.LISOUS(/1)
  1281. NBSO1 = MAX(NBSOUS,1)
  1282.  
  1283. jg = NBSO1
  1284. SEGINI,MLENTI
  1285. IJGROU.ILENTI(ii)=MLENTI
  1286.  
  1287. IPT2 = IPT1
  1288.  
  1289. jg = 0
  1290. DO ISOU = 1, NBSO1
  1291. IF (NBSOUS .GE. 1) THEN
  1292. IPT2 = IPT1.LISOUS(ISOU)
  1293. ENDIF
  1294. itype = IPT2.ITYPEL
  1295. c#DBG write(ioimp,*) '401',ii,isou,ipt2,itype,MEDEL(itype),MED_NONE
  1296.  
  1297. C Gestion des types d'elements non traites actuellement
  1298. C Test fait auparavant donc a priori inutile ici
  1299. IF (MEDEL(itype) .EQ. MED_NONE) GOTO 401
  1300.  
  1301. C Recherche de ce MELEME dans les FAMILLES existantes
  1302. CALL PLACE2(IJFAM.IFAM,NFA,IDANS,IPT2)
  1303. c#DBG write(ioimp,*) '401-',IDANS,' !!',NFA,IPT2
  1304. IF (IDANS .EQ. 0) THEN
  1305. NFA = NFA + 1
  1306. IDANS = NFA
  1307. IF (IDANS .GT. jf) THEN
  1308. jf = IDANS*2 + 20
  1309. SEGADJ,IJFAM
  1310. ENDIF
  1311.  
  1312. C Determination du FORMAT automatique
  1313. IFORMA= INT(LOG10(REAL(IDANS))) + 1
  1314. IF (IFORMA.LT.1 .OR. IFORMA.GT.9) THEN
  1315. CALL ERREUR(1094)
  1316. GOTO 9998
  1317. ENDIF
  1318. ilong = 9+IFORMA
  1319. cha4F ='(I )'
  1320. fname ='FAM_'//NOMS(itype)//'_'
  1321. WRITE(cha4F(3:3) ,FMT='(I1)') IFORMA
  1322. WRITE(fname(10:ilong),FMT= cha4F) IDANS
  1323.  
  1324. kg=20
  1325. SEGINI,NOMGRO
  1326.  
  1327. IJFAM.IFAM(IDANS) = IPT2
  1328. IJFAM.INUMF(IDANS) =-IDANS
  1329. IJFAM.INOGRO(IDANS) = NOMGRO
  1330. IJFAM.CNOMFA(IDANS) = fname
  1331.  
  1332. ELSE
  1333. NOMGRO = IJFAM.INOGRO(IDANS)
  1334. ENDIF
  1335.  
  1336. C Il faut repenser LIRE 'MED' avant de decommenter le IF qui suit
  1337. C IF (log1) THEN
  1338. C IJFAM.INUMF(IDANS)= 0
  1339. C ELSE
  1340. kg = NOMGRO.NOGROU(/2)
  1341. NOC = NOMGRO.NOCO + 1
  1342. IF (NOC .GT. kg) THEN
  1343. kg = NOC*2 + 20
  1344. SEGADJ,NOMGRO
  1345. ENDIF
  1346. NOMGRO.NOCO = NOC
  1347. NOMGRO.NOGROU(NOC) = nomg
  1348. C ENDIF
  1349.  
  1350. jg = jg + 1
  1351. MLENTI.LECT(jg) = IDANS
  1352. 401 CONTINUE
  1353. ENDDO
  1354. SEGADJ,MLENTI
  1355. ENDDO
  1356. IJFAM.NFAM = NFA
  1357.  
  1358. C---- Recomposition MAILLAGE global & Ecriture des familles dans MED
  1359. SEGINI,INBTYP
  1360.  
  1361. C-- Cas particulier des POLYGONes (2D) - itype = 32
  1362. IF (NEPOLY.GT.0) THEN
  1363. itype = 32
  1364. jg = MED_MAXCPO
  1365. SEGINI,mlenti
  1366. INBTYP(1,itype) = mlenti
  1367. jg = NCPOLY
  1368. SEGINI,mlent2
  1369. INBTYP(2,itype) = mlent2
  1370. nbelt = NEPOLY
  1371. SEGINI,INUMFA
  1372. INBTYP(3,itype) = INUMFA
  1373. END IF
  1374.  
  1375. c#DBG write(ioimp,*) 'Nombre de familles :',NFA
  1376. DO ii = 1, NFA
  1377. mfnum = IJFAM.INUMF(ii)
  1378. IPT1 = IJFAM.IFAM(ii)
  1379. itype = IPT1.ITYPEL
  1380. nbnn = IPT1.NUM(/1)
  1381. nbelp = IPT1.NUM(/2)
  1382.  
  1383. SEGINI,IPROFI
  1384. IJFAM.IPROF(ii) = IPROFI
  1385.  
  1386. INUMFA = INBTYP(3,itype)
  1387. C------ Accretion des maillages du meme type (ITYPEL)
  1388. if (itype.ne.32) then
  1389. nbini = INBTYP(1,itype)
  1390.  
  1391. nbelt = nbini + nbelp
  1392. nbelem = nbelt
  1393. NBSOUS = 0
  1394. NBREF = 0
  1395. INBTYP(1,itype) = nbelt
  1396. IF (INUMFA .EQ. 0) THEN
  1397. SEGINI,INUMFA
  1398. INBTYP(3,itype) = INUMFA
  1399. SEGINI,IPT2
  1400. IPT2.ITYPEL = itype
  1401. INBTYP(2,itype) = IPT2
  1402. ELSE
  1403. SEGADJ,INUMFA
  1404. IPT2 = INBTYP(2,itype)
  1405. SEGADJ,IPT2
  1406. ENDIF
  1407.  
  1408. C Profil des MAILLAGES et permutation des noeuds Cast3M -> MED
  1409. IPER = MEDPER(itype)
  1410. ielt = nbini
  1411. IF (IPER .GE. 0) THEN
  1412. nn = nbnn-1
  1413. DO iel = 1, nbelp
  1414. ielt = ielt + 1
  1415. INUMFA(ielt) = mfnum
  1416. IPROFI(iel) = ielt
  1417. IPT2.NUM(1,ielt)=ICPR8(IPT1.NUM(1,iel))
  1418. DO ino = 1, nn
  1419. jno = IPERM(IPER+ino)
  1420. IPT2.NUM(ino+1,ielt)=ICPR8(IPT1.NUM(jno,iel))
  1421. ENDDO
  1422. ENDDO
  1423. ELSE
  1424. DO iel = 1,nbelp
  1425. ielt = ielt + 1
  1426. INUMFA(ielt) = mfnum
  1427. IPROFI(iel) = ielt
  1428. DO ino = 1,nbnn
  1429. IPT2.NUM(ino,ielt)=ICPR8(IPT1.NUM(ino,iel))
  1430. ENDDO
  1431. ENDDO
  1432. ENDIF
  1433.  
  1434. c-- cas des polygones :
  1435. else
  1436. mlent2 = INBTYP(2,itype)
  1437. mlenti = INBTYP(1,itype)
  1438.  
  1439. nbini = mlenti.LECT(nbnn)
  1440. nbelt = nbini + nbelp
  1441. mlenti.LECT(nbnn) = nbelt
  1442. c#DBG if (nbelt.gt.LPOLY.LECT(3*nbnn-2)) then
  1443. c#DBG write(ioimp,*) 'itype 32',nbnn,nbelt,'>>> ?'
  1444. c#DBG endif
  1445. ipini = LPOLY.LECT(3*nbnn-1)
  1446. icini = LPOLY.LECT(3*nbnn)
  1447.  
  1448. ielt = ipini + nbini
  1449. inoe = icini + (nbnn * nbini)
  1450.  
  1451. c#DBG write(ioimp,*) '32-',nbnn,nbini,nbelp,nbelt
  1452. c#DBG write(ioimp,*) ' ',ipini,ielt,icini,inoe
  1453. IPER = MEDPER(itype)
  1454. IF (IPER .GE. 0) write(ioimp,*) 'cas non prevu'
  1455.  
  1456. DO iel = 1, nbelp
  1457. ielt = ielt + 1
  1458. INUMFA(ielt) = mfnum
  1459. IPROFI(iel) = ielt
  1460. DO ino = 1,nbnn
  1461. inoe = inoe + 1
  1462. mlent2.LECT(inoe) = ICPR8(IPT1.NUM(ino,iel))
  1463. ENDDO
  1464. ENDDO
  1465.  
  1466. endif
  1467.  
  1468. IF (mfnum .NE. 0) THEN
  1469. fname = IJFAM.CNOMFA(ii)
  1470. NOMGRO = IJFAM.INOGRO(ii)
  1471. n4 = NOMGRO.NOCO
  1472. CALL mfacre(mfid, name,fname, mfnum,n4, NOMGRO.NOGROU, mcret)
  1473. IF (mcret .NE. 0) THEN
  1474. moterr = 'sormed / mfacre'
  1475. interr(1) = mcret
  1476. CALL ERREUR(873)
  1477. GOTO 9998
  1478. ENDIF
  1479. ENDIF
  1480. ENDDO
  1481.  
  1482. C Ajustement de INT4 : INT4(/1) = NBPTS = itaill
  1483. itaill = NBPTS
  1484. DO ii = 1, NOMBR
  1485. ipt1 = INBTYP(2,ii)
  1486. IF (ipt1 .NE. 0) THEN
  1487. if (ii.ne.32) then
  1488. itaill = MAX(itaill, ipt1.num(/1)*ipt1.num(/2))
  1489. else
  1490. itaill = MAX(itaill, 1+NEPOLY+NCPOLY)
  1491. endif
  1492. ENDIF
  1493. ENDDO
  1494. IF (itaill .GT. INT4(/1)) SEGADJ,INT4
  1495.  
  1496. C Boucle sur tous les TYPES d'elements ('POI1', etc.)
  1497. c#DBG write(ioimp,*)
  1498. c#DBG write(ioimp,*) 'Boucle sur les types d elements',NOMBR
  1499. DO ii = 1, NOMBR
  1500.  
  1501. IPT1 = INBTYP(2,ii)
  1502. IF (IPT1 .EQ. 0) GOTO 503
  1503.  
  1504. numdt = MED_NO_DT
  1505. numit = MED_NO_IT
  1506. dt = MED_UNDEF_DT
  1507. metype = MED_CELL
  1508. mcmode = MED_NODAL
  1509. mswm = MED_FULL_INTERLACE
  1510.  
  1511. C------ Ecriture des connectivites
  1512. if (ii.eq.32) goto 532
  1513.  
  1514. C ***** Cas general *****
  1515. nbnn = IPT1.NUM(/1)
  1516. nbelem = IPT1.NUM(/2)
  1517. itype = IPT1.ITYPEL
  1518. mgtype = MEDEL(itype)
  1519. c#DBG write(ioimp,*) '5xx ',ii,IPT1,itype,mgtype
  1520.  
  1521. itaill = nbnn * nbelem
  1522. CALL mhcyw4(mfid, name, numdt, numit, dt, metype,mgtype,mcmode,
  1523. & mswm, nbelem, IPT1.NUM, INT4(1), mcret, itaill)
  1524. IF (mcret .NE. 0) THEN
  1525. moterr = 'sormed / mhcyw4'
  1526. interr(1) = mcret
  1527. CALL ERREUR(873)
  1528. GOTO 9998
  1529. ENDIF
  1530.  
  1531. itaill = nbelem
  1532. GOTO 510
  1533.  
  1534. C-- Cas des POLYGONES :
  1535. 532 CONTINUE
  1536. mgtype = MEDEL(ii)
  1537. c#DBG write(ioimp,*) '532 ',ii,IPT1,MED_POLYGON,mgtype
  1538.  
  1539. NEIND = NEPOLY + 1
  1540. jg = NEIND
  1541. SEGINI,mlent3
  1542. iel = 1
  1543. mlent3.LECT(iel) = 1
  1544. DO ino = 1, MED_MAXCPO
  1545. nbelem = LPOLY.LECT(3*ino-2)
  1546. DO j = 1, nbelem
  1547. iel = iel + 1
  1548. mlent3.LECT(iel) = mlent3.LECT(iel-1) + ino
  1549. END DO
  1550. END DO
  1551. mlent2 = INBTYP(2,ii)
  1552. c#DBG write(ioimp,*) 'MLENT3',NEIND,NEPOLY
  1553. c#DBG write(ioimp,*) (mlent3.LECT(j),j=1,NEIND)
  1554. c#DBG write(ioimp,*) 'MLENT2',NCPOLY
  1555. c#DBG write(ioimp,*) (mlent2.LECT(j),j=1,NCPOLY)
  1556.  
  1557. CALL mhpgw4(mfid, name, numdt, numit, dt, metype, mcmode,
  1558. & mlent3.LECT(1),mlent2.LECT(1), INT4(1),
  1559. & mcret, NEIND,NCPOLY)
  1560. SEGSUP,mlent3
  1561. IF (mcret .NE. 0) THEN
  1562. moterr = 'sormed / mhpgw4'
  1563. interr(1) = mcret
  1564. CALL ERREUR(873)
  1565. GOTO 9998
  1566. ENDIF
  1567.  
  1568. itaill = NEPOLY
  1569. GOTO 510
  1570.  
  1571. C------ Ecriture du numero de famille a laquelle appartiennent les ELEMENTS
  1572. 510 CONTINUE
  1573. INUMFA = INBTYP(3,ii)
  1574. CALL mhfnw4(mfid, name, numdt, numit, metype, mgtype, itaill,
  1575. & INUMFA(1), INT4(1), mcret)
  1576. IF (mcret .NE. 0) THEN
  1577. moterr = 'sormed / mhfnw4'
  1578. interr(1) = mcret
  1579. CALL ERREUR(873)
  1580. GOTO 9998
  1581. ENDIF
  1582.  
  1583. 503 CONTINUE
  1584. ENDDO
  1585.  
  1586. C **********************************************************************
  1587. C Ecriture des CHPOINTS : Creation champs MED: profils et valeurs
  1588. C **********************************************************************
  1589. IF (LISCHP .GT. 0) THEN
  1590. CALL SMDCHP(mfid, name, IJGROU, LISCHP, ICPR8)
  1591. ENDIF
  1592.  
  1593. C **********************************************************************
  1594. C Ecriture des MCHAML : Creation champs MED: profils et valeurs
  1595. C **********************************************************************
  1596. IF (LISCHA .GT. 0) THEN
  1597. CALL SMDCHM(mfid, name, IJFAM, IJGROU, LISCHA, ICPR8)
  1598. ENDIF
  1599.  
  1600. C **********************************************************************
  1601. C Fermeture du fichier MED 4.*
  1602. C **********************************************************************
  1603. 9998 CONTINUE
  1604. CALL mficlo(mfid, mcret)
  1605. IF (mcret .NE. 0) THEN
  1606. moterr = 'sormed / mficlo'
  1607. interr(1) = mcret
  1608. CALL ERREUR(873)
  1609. ENDIF
  1610.  
  1611. IF (INBTYP.NE.0) THEN
  1612. DO ii = 1, NOMBR
  1613. if (ii.EQ.32) then
  1614. mlenti = INBTYP(1,ii)
  1615. IF (mlenti.NE.0) SEGSUP,mlenti
  1616. mlent2 = INBTYP(2,ii)
  1617. IF (mlent2.NE.0) SEGSUP,mlent2
  1618. else
  1619. IPT1 = INBTYP(2,ii)
  1620. IF (IPT1 .NE. 0) SEGSUP,IPT1
  1621. endif
  1622. INUMFA = INBTYP(3,ii)
  1623. IF (INUMFA.NE.0) SEGSUP,INUMFA
  1624. END DO
  1625. SEGSUP,INBTYP
  1626. END IF
  1627.  
  1628. C **********************************************************************
  1629. C Fin du traitement - Fermeture/Destruction des segments
  1630. C **********************************************************************
  1631. 9999 CONTINUE
  1632.  
  1633. IF (NBESC.NE.0) SEGDES,IPILOC
  1634. SEGDES,MCOORD
  1635.  
  1636. NBMAIL = ITLAC1(/1)
  1637. IF (NBMAIL.GT.1 .AND. IPT8.GT.0) SEGSUP,IPT8
  1638. SEGSUP,ITLAC1
  1639. SEGSUP,LPOLY
  1640. IF (SREPE1.NE.0) SEGSUP,SREPE1
  1641. IF (SREPE2.NE.0) SEGSUP,SREPE2
  1642. IF (SREPE3.NE.0) SEGSUP,SREPE3
  1643. IF (ICPR8 .NE.0) SEGSUP,ICPR8
  1644. IF (ICOO .NE.0) SEGSUP,ICOO
  1645. IF (LISCHA.NE.0) SEGSUP,LISCHA
  1646. IF (LISCHP.NE.0) SEGSUP,LISCHP
  1647. IF (INT4 .NE.0) SEGSUP,INT4
  1648.  
  1649. c return
  1650. END
  1651.  
  1652.  
  1653.  

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