# test7.f90

Aller à la documentation de ce fichier.

    00001 !*  This file is part of MED.
    00002 !*
    00003 !*  COPYRIGHT (C) 1999 - 2011  EDF R&D, CEA/DEN
    00004 !*  MED is free software: you can redistribute it and/or modify
    00005 !*  it under the terms of the GNU Lesser General Public License as published by
    00006 !*  the Free Software Foundation, either version 3 of the License, or
    00007 !*  (at your option) any later version.
    00008 !*
    00009 !*  MED is distributed in the hope that it will be useful,
    00010 !*  but WITHOUT ANY WARRANTY; without even the implied warranty of
    00011 !*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    00012 !*  GNU Lesser General Public License for more details.
    00013 !*
    00014 !*  You should have received a copy of the GNU Lesser General Public License
    00015 !*  along with MED.  If not, see <http://www.gnu.org/licenses/>.
    00016 !*
    00017
    00018 ! ******************************************************************************
    00019 ! * - Nom du fichier : test7.f90
    00020 ! *
    00021 ! * - Description : lecture des elements du maillage MED ecrits par test6
    00022 ! *
    00023 ! ******************************************************************************
    00024       program test7
    00025
    00026       implicit none
    00027       include 'med.hf'
    00028 !
    00029 !
    00030       integer cret, ret, fid
    00031
    00032       integer nse2
    00033       integer,     allocatable, dimension (:) :: se2,se21
    00034       character*16, allocatable, dimension (:) :: nomse2
    00035       integer,     allocatable, dimension (:) :: numse2,nufase2
    00036
    00037       integer ntr3
    00038       integer,     allocatable, dimension (:) :: tr3
    00039       character*16, allocatable, dimension (:) :: nomtr3
    00040       integer,     allocatable, dimension (:) :: numtr3,nufatr3
    00041
    00042 !     ** nom du maillage de longueur maxi MED_TAILLE_NOM    **
    00043       character*64  :: maa
    00044       character*200 :: desc
    00045       integer       :: mdim,edim,nstep,stype,atype
    00046       logical inoele,inuele
    00047       integer, parameter :: profil (2) = (/ 2,3 /)
    00048       integer type
    00049       integer tse2,ttr3, i
    00050       character*16 nomcoo(2)
    00051       character*16 unicoo(2)
    00052       character*16 dtunit
    00053       integer :: chgt,tsf
    00054       integer flta(1)
    00055       integer*8 flt(1)
    00056
    00057 !   ** Ouverture du fichier test6.med en lecture seule       **
    00058       call mfiope(fid,'test6.med',MED_ACC_RDONLY, cret)
    00059       print *,cret
    00060
    00061 !   ** Lecture des infos concernant le premier maillage      **
    00062       if (cret.eq.0) then
    00063          call mmhmii(fid,1,maa,edim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,cret)
    00064          print *,"Maillage de nom : ",maa," et de dimension :", mdim
    00065       endif
    00066       if (cret.ne.0) then
    00067          call efexit(-1)
    00068       endif
    00069 !   ** Combien de segments et de triangles                   **
    00070       if (cret.eq.0) then
    00071          nse2 = 0
    00072          call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,nse2,cret)
    00073       endif
    00074       if (cret.ne.0) then
    00075          call efexit(-1)
    00076       endif
    00077
    00078       if (cret.eq.0) then
    00079          ntr3 = 0
    00080          call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,ntr3,cret)
    00081       endif
    00082       if (cret.ne.0) then
    00083          call efexit(-1)
    00084       endif
    00085
    00086       if (cret.eq.0) then
    00087          print *,"Nombre de MED_SEG2 : ",nse2," - nombre de MED_TRIA3 : ",ntr3
    00088       endif
    00089
    00090 !   ** Allocations memoire                                 **
    00091       tse2 = 2
    00092       allocate (se2(tse2*nse2),se21(tse2*nse2),nomse2(nse2),numse2(nse2), nufase2(nse2),STAT=ret )
    00093       se2(:)=0; se21(:)=0
    00094 !      print *,ret
    00095
    00096       ttr3 = 3
    00097       allocate (tr3(ntr3*ttr3), nomtr3(ntr3), numtr3(ntr3),nufatr3(ntr3),STAT=ret )
    00098       tr3(:)=0
    00099 !      print *,ret
    00100
    00101
    00102 !   ** Lecture de la connectivite des segments           **
    00103       if (cret.eq.0) then
    00104         call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING,MED_FULL_INTERLACE,se2,cret)
    00105       endif
    00106       if (cret.ne.0) then
    00107          call efexit(-1)
    00108       endif
    00109       print *,se2
    00110
    00111 !    ** Lecture de de la composante 2 de la connectivite des segments           **
    00112 !    ** On cree un filtre  associe
    00113      if (cret .eq. 0) then
    00114         call mfrall(1,flt,cret)
    00115      endif
    00116      if (cret.ne.0) then
    00117         call efexit(-1)
    00118      endif
    00119
    00120 !    ** on initialise le filtre pour lire uniquement la deuxième composante.
    00121      if (cret .eq. 0) then
    00122         call mfrcre(fid,nse2,1,edim,2,MED_FULL_INTERLACE,MED_GLOBAL_PFLMODE, &
    00123                     MED_NO_PROFILE,MED_UNDEF_SIZE,flta,flt(1),cret)
    00124      endif
    00125      if (cret.ne.0) then
    00126         call efexit(-1)
    00127      endif
    00128
    00129 !   ** Lecture des composantes n°2 des segments
    00130      if (cret.eq.0) then
    00131         call mmhyar(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING, &
    00132                     flt(1),se21,cret)
    00133      endif
    00134      if (cret.ne.0) then
    00135         call efexit(-1)
    00136      endif
    00137      print *,se21
    00138
    00139 !   ** On desalloue le filtre
    00140      if (cret .eq. 0) then
    00141         call mfrdea(1,flt,cret)
    00142      endif
    00143      if (cret.ne.0) then
    00144         call efexit(-1)
    00145      endif
    00146
    00147 !   ** Lecture (optionnelle) des noms des segments         **
    00148       if (cret.eq.0) then
    00149          call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nomse2,cret)
    00150       endif
    00151
    00152       if (ret <0) then
    00153          inoele = .FALSE.
    00154       else
    00155          inoele = .TRUE.
    00156       endif
    00157
    00158 !  ** Lecture (optionnelle) des numeros des segments       **
    00159       if (cret.eq.0) then
    00160          call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,numse2,cret)
    00161      endif
    00162
    00163      if (ret <0) then
    00164         inuele = .FALSE.
    00165      else
    00166         inuele = .TRUE.
    00167      endif
    00168
    00169 !  ** Lecture des numeros des familles des segments         **
    00170      if (cret.eq.0) then
    00171         call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nufase2,cret)
    00172       endif
    00173      if (cret.ne.0) then
    00174         call efexit(-1)
    00175      endif
    00176
    00177 !  ** Lecture de la connectivite des triangles sans profil **
    00178       if (cret.eq.0) then
    00179         call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_DESCENDING,MED_NO_INTERLACE,tr3,cret)
    00180       endif
    00181      if (cret.ne.0) then
    00182         call efexit(-1)
    00183      endif
    00184
    00185 !  ** Lecture (optionnelle) des noms des triangles          **
    00186       if (cret.eq.0) then
    00187          call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nomtr3,cret)
    00188       endif
    00189
    00190       if (ret <0) then
    00191          inoele = .FALSE.
    00192       else
    00193          inoele = .TRUE.
    00194       endif
    00195       print *,cret
    00196
    00197 !  ** Lecture (optionnelle) des numeros des segments       **
    00198       if (cret.eq.0) then
    00199         call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,numtr3,cret)
    00200      endif
    00201
    00202      if (ret <0) then
    00203         inuele = .FALSE.
    00204      else
    00205         inuele = .TRUE.
    00206      endif
    00207      print *,cret
    00208
    00209 !  ** Lecture des numeros des familles des segments         **
    00210      if (cret.eq.0) then
    00211         call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nufatr3,cret)
    00212       endif
    00213       print *,cret
    00214
    00215 !  ** Fermeture du fichier                                           **
    00216      call mficlo(fid,cret)
    00217      if (cret.ne.0) then
    00218         call efexit(-1)
    00219      endif
    00220
    00221 !  ** Affichage des resulats                                         **
    00222      if (cret.eq.0) then
    00223
    00224         print *,"Connectivite des segments : "
    00225         print *, se2
    00226
    00227         if (inoele) then
    00228            print *,"Noms des segments :"
    00229            print *,nomse2
    00230         endif
    00231
    00232         if (inuele) then
    00233            print *,"Numeros des segments :"
    00234            print *,numse2
    00235         endif
    00236
    00237         print *,"Numeros des familles des segments :"
    00238         print *,nufase2
    00239
    00240         print *,"Connectivite des triangles :"
    00241         print *,tr3
    00242
    00243         if (inoele) then
    00244            print *,"Noms des triangles :"
    00245            print *,nomtr3
    00246         endif
    00247
    00248         if (inuele) then
    00249            print *,"Numeros des triangles :"
    00250            print *,numtr3
    00251         endif
    00252
    00253         print *,"Numeros des familles des triangles :"
    00254         print *,nufatr3
    00255
    00256      endif
    00257
    00258 !  ** Nettoyage memoire                                          **
    00259       deallocate (se2,se21,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3)
    00260
    00261 !  ** Code retour
    00262       call efexit(cret)
    00263
    00264     end program test7
    00265