# f/2.3.6/test6.f

    00001 C*  This file is part of MED.
    00002 C*
    00003 C*  COPYRIGHT (C) 1999 - 2012  EDF R&D, CEA/DEN
    00004 C*  MED is free software: you can redistribute it and/or modify
    00005 C*  it under the terms of the GNU Lesser General Public License as published by
    00006 C*  the Free Software Foundation, either version 3 of the License, or
    00007 C*  (at your option) any later version.
    00008 C*
    00009 C*  MED is distributed in the hope that it will be useful,
    00010 C*  but WITHOUT ANY WARRANTY; without even the implied warranty of
    00011 C*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    00012 C*  GNU Lesser General Public License for more details.
    00013 C*
    00014 C*  You should have received a copy of the GNU Lesser General Public License
    00015 C*  along with MED.  If not, see <http://www.gnu.org/licenses/>.
    00016 C*
    00017
    00018 C       *******************************************************************************
    00019 C       * - Nom du fichier : test6.f
    00020 C       *
    00021 C       * - Description : exemples d'ecriture d'elements dans un maillage MED
    00022 C       *
    00023 C       ******************************************************************************
    00024         program test6
    00025 C
    00026         implicit none
    00027         include 'med.hf'
    00028 C
    00029 C
    00030         integer cret, fid
    00031
    00032         integer     mdim,nse2,ntr3
    00033         parameter  (nse2 = 5, ntr3 = 2, mdim = 2)
    00034         integer     se2 (2*nse2)
    00035         character*16 nomse2(nse2)
    00036         integer     numse2(nse2),nufase2(nse2)
    00037
    00038         integer     tr3 (3*ntr3)
    00039         character*16 nomtr3(ntr3)
    00040         integer     numtr3(ntr3), nufatr3(ntr3)
    00041         character*32 maa
    00042
    00043         data se2     / 1,2,1,3,2,4,3,4,2,3 /
    00044         data nomse2  /"se1","se2","se3","se4","se5" /
    00045         data numse2  / 1,2,3,4,5 /, nufase2 /-1,-1,0,-2,-3/
    00046         data tr3     /1,2,-5,-5,3,-4 /, nomtr3 /"tr1","tr2"/,
    00047      &                                  numtr3 /4,5/
    00048         data nufatr3 /0,-1/,  maa /"maa1"/
    00049
    00050 C       ** Ouverture du fichier                            **
    00051         call efouvr(fid,'test6.med',MED_LECTURE_ECRITURE, cret)
    00052         print *,cret
    00053         if (cret .ne. 0 ) then
    00054            print *,'Erreur creation du fichier'
    00055            call efexit(-1)
    00056         endif
    00057
    00058 C       ** Creation du maillage maa de dimension 2         **
    00059         call efmaac(fid,maa,mdim,MED_NON_STRUCTURE,
    00060      &                 'un maillage pour test6',cret)
    00061         print *,cret
    00062         if (cret .ne. 0 ) then
    00063            print *,'Erreur creation du maillage'
    00064            call efexit(-1)
    00065         endif
    00066
    00067 C       ** Ecriture des connectivites des segments         **
    00068         call efcone(fid,maa,mdim,se2,MED_NO_INTERLACE,
    00069      &               nse2,MED_ARETE,
    00070      &               MED_SEG2,MED_DESC,cret )
    00071         print *,cret
    00072         if (cret .ne. 0 ) then
    00073            print *,'Erreur ecriture de la connectivite'
    00074            call efexit(-1)
    00075         endif
    00076
    00077 C       ** Ecriture (optionnelle) des noms des segments    **
    00078         call efnome(fid,maa,nomse2,nse2,MED_ARETE,
    00079      &                        MED_SEG2 ,cret)
    00080         print *,cret
    00081         if (cret .ne. 0 ) then
    00082            print *,'Erreur ecriture des noms'
    00083            call efexit(-1)
    00084         endif
    00085
    00086 C       ** Ecriture (optionnelle) des numeros des segments **
    00087         call efnume(fid,maa,numse2,nse2,
    00088      &              MED_ARETE ,MED_SEG2,cret)
    00089         print *,cret
    00090         if (cret .ne. 0 ) then
    00091            print *,'Erreur ecriture des numeros'
    00092            call efexit(-1)
    00093         endif
    00094
    00095 C       ** Ecriture des numeros des familles des segments  **
    00096         call effame(fid,maa,nufase2,nse2,
    00097      &              MED_ARETE,MED_SEG2,cret)
    00098         print *,cret
    00099         if (cret .ne. 0 ) then
    00100            print *,'Erreur ecriture des numéros de famille'
    00101            call efexit(-1)
    00102         endif
    00103
    00104 C       ** Ecriture des connectivites des triangles        **
    00105         call efcone(fid,maa,mdim,tr3,MED_NO_INTERLACE,
    00106      &              ntr3,MED_MAILLE,
    00107      &              MED_TRIA3,MED_DESC,cret )
    00108         print *,cret
    00109         if (cret .ne. 0 ) then
    00110            print *,'Erreur ecriture de la connectivite'
    00111            call efexit(-1)
    00112         endif
    00113
    00114 C       ** Ecriture (optionnelle) des noms des triangles   **
    00115         call efnome(fid,maa,nomtr3,ntr3,MED_MAILLE,
    00116      &                        MED_TRIA3,cret)
    00117         print *,cret
    00118         if (cret .ne. 0 ) then
    00119            print *,'Erreur ecriture des noms'
    00120            call efexit(-1)
    00121         endif
    00122
    00123 C       ** Ecriture (optionnelle) des numeros des triangles **
    00124         call efnume(fid,maa,numtr3,ntr3,MED_MAILLE,
    00125      &                       MED_TRIA3,cret)
    00126         print *,cret
    00127         if (cret .ne. 0 ) then
    00128            print *,'Erreur ecriture des numeros'
    00129            call efexit(-1)
    00130         endif
    00131
    00132 C      ** Ecriture des numeros des familles des triangles  **
    00133         call effame(fid,maa,nufatr3,ntr3,MED_MAILLE,
    00134      &                      MED_TRIA3,cret)
    00135         print *,cret
    00136         if (cret .ne. 0 ) then
    00137            print *,'Erreur ecriture des numeros de famille'
    00138            call efexit(-1)
    00139         endif
    00140
    00141 C       ** Fermeture du fichier   **
    00142         call efferm (fid,cret)
    00143         print *,cret
    00144         if (cret .ne. 0 ) then
    00145            print *,'Erreur a la fermeture du fichier'
    00146            call efexit(-1)
    00147         endif
    00148 C
    00149         end