# f/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,sdim
    00033         parameter  (nse2=5, ntr3=2, mdim=2, sdim=2)
    00034         integer     se2 (2*nse2)
    00035         character*16 nomse2(nse2)
    00036         integer     numse2(nse2),nufase2(nse2)
    00037
    00038         character*16 nomcoo(2)
    00039         character*16 unicoo(2)
    00040
    00041
    00042         integer     tr3 (3*ntr3)
    00043         character*16 nomtr3(ntr3)
    00044         integer     numtr3(ntr3), nufatr3(ntr3)
    00045         character*64 maa
    00046         real*8 dt
    00047         parameter (dt = 0.0)
    00048
    00049         data  nomcoo /"x","y"/, unicoo /"cm","cm"/
    00050         data se2     / 1,2,1,3,2,4,3,4,2,3 /
    00051         data nomse2  /"se1","se2","se3","se4","se5" /
    00052         data numse2  / 1,2,3,4,5 /, nufase2 /-1,-1,0,-2,-3/
    00053         data tr3     /1,2,-5,-5,3,-4 /, nomtr3 /"tr1","tr2"/,
    00054      &                                  numtr3 /4,5/
    00055         data nufatr3 /0,-1/,  maa /"maa1"/
    00056
    00057 C       ** Ouverture du fichier
    00058         call mfiope(fid,'test6.med',MED_ACC_CREAT, cret)
    00059         print *,cret
    00060         if (cret .ne. 0 ) then
    00061            print *,'Erreur creation du fichier'
    00062            call efexit(-1)
    00063         endif
    00064
    00065 C       ** Creation du maillage maa de dimension 2         **
    00066         call mmhcre(fid,maa,mdim,sdim,
    00067      &     MED_UNSTRUCTURED_MESH,'un maillage pour test6',
    00068      &     "",MED_SORT_DTIT,MED_CARTESIAN,nomcoo,unicoo,cret)
    00069         print *,cret
    00070         if (cret .ne. 0 ) then
    00071            print *,'Erreur creation du maillage'
    00072            call efexit(-1)
    00073         endif
    00074
    00075 C       ** Ecriture des connectivites des segments         **
    00076         call mmhcyw(fid,maa,MED_NO_DT,MED_NO_IT,dt,
    00077      &              MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING,
    00078      &              MED_NO_INTERLACE,nse2,se2,cret)
    00079         print *,cret
    00080         if (cret .ne. 0 ) then
    00081            print *,'Erreur ecriture de la connectivite'
    00082            call efexit(-1)
    00083         endif
    00084
    00085 C       ** Ecriture (optionnelle) des noms des segments    **
    00086         call mmheaw(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,
    00087      &              MED_SEG2,nse2,nomse2,cret)
    00088         print *,cret
    00089         if (cret .ne. 0 ) then
    00090            print *,'Erreur ecriture des noms'
    00091            call efexit(-1)
    00092         endif
    00093
    00094 C       ** Ecriture (optionnelle) des numeros des segments **
    00095         call mmhenw(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,
    00096      &              MED_SEG2,nse2,numse2,cret)
    00097         print *,cret
    00098         if (cret .ne. 0 ) then
    00099            print *,'Erreur ecriture des numeros'
    00100            call efexit(-1)
    00101         endif
    00102
    00103 C       ** Ecriture des numeros des familles des segments  **
    00104         call mmhfnw(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,
    00105      &              MED_SEG2,nse2,nufase2,cret)
    00106         print *,cret
    00107         if (cret .ne. 0 ) then
    00108            print *,'Erreur ecriture des numéros de famille'
    00109            call efexit(-1)
    00110         endif
    00111
    00112 C       ** Ecriture des connectivites des triangles        **
    00113         call mmhcyw(fid,maa,MED_NO_DT,MED_NO_IT,dt,
    00114      &              MED_CELL,MED_TRIA3,MED_DESCENDING,
    00115      &              MED_NO_INTERLACE,ntr3,tr3,cret)
    00116         print *,cret
    00117         if (cret .ne. 0 ) then
    00118            print *,'Erreur ecriture de la connectivite'
    00119            call efexit(-1)
    00120         endif
    00121
    00122 C       ** Ecriture (optionnelle) des noms des triangles   **
    00123         call mmheaw(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,
    00124      &              MED_TRIA3,ntr3,nomtr3,cret)
    00125         print *,cret
    00126         if (cret .ne. 0 ) then
    00127            print *,'Erreur ecriture des noms'
    00128            call efexit(-1)
    00129         endif
    00130
    00131 C       ** Ecriture (optionnelle) des numeros des triangles **
    00132         call mmhenw(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,
    00133      &              MED_TRIA3,ntr3,numtr3,cret)
    00134         print *,cret
    00135         if (cret .ne. 0 ) then
    00136            print *,'Erreur ecriture des numeros'
    00137            call efexit(-1)
    00138         endif
    00139
    00140 C      ** Ecriture des numeros des familles des triangles  **
    00141         call mmhfnw(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,
    00142      &              MED_TRIA3,ntr3,nufatr3,cret)
    00143         print *,cret
    00144         if (cret .ne. 0 ) then
    00145            print *,'Erreur ecriture des numeros de famille'
    00146            call efexit(-1)
    00147         endif
    00148
    00149 C       ** Fermeture du fichier   **
    00150         call mficlo(fid,cret)
    00151         print *,cret
    00152         if (cret .ne. 0 ) then
    00153            print *,'Erreur a la fermeture du fichier'
    00154            call efexit(-1)
    00155         endif
    00156 C
    00157         end