Télécharger la plaquette Cast3M


fr en

Télécharger sormed.eso

Retour à la liste

Numérotation des lignes : 

sormed

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

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