# test11b.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 ! ******************************************************************************
    00020 ! * - Nom du fichier : test11.f90
    00021 ! *
    00022 ! * - Description : lecture de champs de resultats MED
    00023 ! *
    00024 ! *****************************************************************************
    00025
    00026 program test11
    00027
    00028   implicit none
    00029   include 'med.hf'
    00030
    00031
    00032   integer       cret,ret,lret,retmem, fid
    00033   integer       USER_INTERLACE,USER_MODE
    00034   character*64  :: maa,nomcha,pflname,nomlien,locname
    00035   character*200 desc
    00036   character*255 argc
    00037   character*16, allocatable, dimension(:) :: comp,unit
    00038   character*16  dtunit
    00039   integer       mdim,ncomp,ncha,npro,nln,pflsize,nval
    00040   integer,      allocatable, dimension(:) :: pflval
    00041   integer       ngauss,nloc
    00042   integer       t1,t2,t3,typcha,type,type_geo
    00043   real*8,       allocatable, dimension(:) :: refcoo, gscoo, wg
    00044   character*255 lien
    00045   integer       i,j
    00046   integer       getFieldsOn
    00047   integer nstep, stype, atype,sdim
    00048   character*16 nomcoo(3)
    00049   character*16 unicoo(3)
    00050   integer lmesh, ncst
    00051   character*64  :: giname, isname
    00052   integer nsmc, sgtype
    00053
    00054   parameter (USER_INTERLACE = MED_FULL_INTERLACE)
    00055   parameter (USER_MODE = MED_COMPACT_PFLMODE)
    00056
    00057   cret=0;ret=0;lret=0;retmem=0
    00058   print *,"Indiquez le fichier med a decrire : "
    00059   !!read(*,'(A)') argc
    00060   argc="test10.med"
    00061
    00062   !  ** ouverture du fichier **
    00063   call mfiope(fid,argc,MED_ACC_RDONLY, ret)
    00064   if (ret .ne. 0) call efexit(-1)
    00065
    00066   !  ** info sur le premier maillage **
    00067   if (ret.eq.0) then
    00068      call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
    00069   endif
    00070   if (ret.ne.0) then
    00071      print *, "Erreur a la lecture des informations sur le maillage : ", &
    00072           & maa,mdim,type,desc
    00073      call efexit(-1)
    00074   endif
    00075
    00076   write (*,'(/A,A,A,I1)') "Maillage de nom |",TRIM(maa),"| et de dimension ",mdim
    00077
    00078   !  ** combien de champs dans le fichier **
    00079   call mfdnfd(fid,ncha,ret)
    00080   if (ret.ne.0) then
    00081      print *, "Impossible de lire le nombre de champs : ",ncha
    00082      call efexit(-1)
    00083   endif
    00084
    00085   write (*,'(A,I1/)') "Nombre de champs : ",ncha
    00086
    00087
    00088   ! ** lecture de tous les champs associes a <maa> **
    00089   do i=1,ncha
    00090      lret = 0
    00091      write(*,'(A,I5)') "- Champ numero : ",i
    00092
    00093      ! ** combien de composantes **
    00094      call mfdnfc(fid,i,ncomp,ret)
    00095      !   print *,ncomp,ret
    00096      if (ret.ne.0) then
    00097         print *, "Erreur a la lecture du nombre de composantes : ",ncomp
    00098         cret = -1
    00099      endif
    00100
    00101      ! ** allocation memoire de comp et unit **
    00102      allocate(comp(ncomp),unit(ncomp),STAT=retmem)
    00103      if (retmem .ne. 0) then
    00104         print *, "Erreur a l'allocation mémoire de comp et unit : "
    00105         call efexit(-1)
    00106      endif
    00107
    00108      ! ** Info sur les champs
    00109      call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
    00110      if (ret .ne. 0) then
    00111         print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
    00112         cret = -1
    00113         continue
    00114      endif
    00115
    00116      write(*,'(/5X,A,A)') 'Nom du champ  : ', TRIM(nomcha)
    00117      write(*,'(/5X,A,A)') 'Nom du maillage : ',TRIM(maa)
    00118      write(*,'(5X,A,I5)') 'Type du champ : ', typcha
    00119      do j=1,ncomp
    00120         write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,'  : ',TRIM(comp(j)),' ',TRIM(unit(j))
    00121      enddo
    00122      write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
    00123      print *,""
    00124
    00125      deallocate(comp,unit)
    00126
    00127      lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE, USER_INTERLACE, ncst)
    00128      ! print *,lret
    00129
    00130      if (lret .eq. 0) then
    00131         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_CELL, USER_INTERLACE, ncst)
    00132      else
    00133         print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
    00134      endif
    00135
    00136      if (lret .eq. 0) then
    00137         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_FACE,USER_INTERLACE, ncst)
    00138      else
    00139         print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
    00140      endif
    00141
    00142      if (lret .eq. 0) then
    00143         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_EDGE,USER_INTERLACE, ncst)
    00144      else
    00145         print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
    00146      endif
    00147
    00148      if (lret .eq. 0) then
    00149         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE_ELEMENT,USER_INTERLACE, ncst)
    00150      else
    00151         print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
    00152      endif
    00153
    00154      if  (lret .ne. 0) then
    00155         print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
    00156      endif
    00157
    00158   enddo
    00159
    00160
    00161   call mpfnpf(fid,nval,ret)
    00162   write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
    00163
    00164   if (nval .gt. 0 ) then
    00165      do i=1,nval
    00166            call mpfpfi(fid,i,pflname,nval,ret)
    00167         write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
    00168      enddo
    00169   endif
    00170
    00171
    00172   !  ** Interrogation des liens **
    00173   call mlnnln(fid,nln,ret)
    00174   if (ret.ne.0) then
    00175      print *,"Erreur a la lecture du nombre de liens : " &
    00176           & ,nln
    00177      cret = -1;
    00178   else
    00179      print *,""
    00180      write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
    00181      do i=1,nln
    00182         call mlnlni(fid, i, nomlien, nval, ret)
    00183         if (ret.ne.0) then
    00184            print *,"Erreur a la demande d'information sur le lien n° : ",i
    00185            cret = -1;continue;
    00186         endif
    00187         write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
    00188         !! allocate
    00189         lien = ""
    00190         call mlnlir(fid,nomlien,lien,ret)
    00191         if (ret.ne.0) then
    00192            print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
    00193            ret = -1;
    00194         else
    00195            write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
    00196         endif
    00197         !!deallocate
    00198      end do
    00199   endif
    00200
    00201
    00202   !  ** Interrogation des localisations des points de GAUSS **
    00203   call mlcnlc(fid,nloc,ret)
    00204   if (ret.ne.0) then
    00205      print *,"Erreur a la lecture du nombre de points de Gauss : " &
    00206           & ,nloc
    00207      cret = -1;
    00208   else
    00209      print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
    00210      do i=1,nloc
    00211         call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
    00212         if (ret.ne.0) then
    00213            print *,"Erreur a la demande d'information sur la localisation n° : ",i
    00214            cret = -1;continue;
    00215         endif
    00216         write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
    00217              &,"| à",ngauss, " points d'intégration dans un espace de dimension ",sdim
    00218         t1 = MOD(type_geo,100)*sdim
    00219         t2 = ngauss*sdim
    00220         t3 = ngauss
    00221         allocate(refcoo(t1),STAT=retmem)
    00222         if (retmem .ne. 0) then
    00223            print *, "Erreur a l'allocation mémoire de refcoo : "
    00224            call efexit(-1)
    00225         endif;
    00226         allocate(gscoo(t2),STAT=retmem)
    00227         if (retmem .ne. 0) then
    00228            print *, "Erreur a l'allocation mémoire de gscoo : "
    00229            call efexit(-1)
    00230         endif;
    00231         allocate(wg(t3),STAT=retmem)
    00232         if (retmem .ne. 0) then
    00233            print *, "Erreur a l'allocation mémoire de wg : "
    00234            call efexit(-1)
    00235         endif;
    00236         call mlclor(fid, locname,USER_INTERLACE,refcoo,gscoo,wg, ret )
    00237         if (ret.ne.0) then
    00238            print *,"Erreur a la lecture  des valeurs de la localisation : " &
    00239                 & ,locname
    00240            cret = -1;
    00241         else
    00242            write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
    00243            do j=1,t1
    00244               write (*,'(5X,E20.8)') refcoo(j)
    00245            enddo
    00246            print *,""
    00247            write (*,'(5X,A)') "Localisation des points de GAUSS : "
    00248            do j=1,t2
    00249               write (*,'(5X,E20.8)') gscoo(j)
    00250            enddo
    00251            print *,""
    00252            write (*,'(5X,A)') "Poids associes aux points de GAUSS "
    00253            do j=1,t3
    00254               write (*,'(5X,E20.8)') wg(j)
    00255            enddo
    00256            print *,""
    00257         endif
    00258         deallocate(refcoo)
    00259         deallocate(gscoo)
    00260         deallocate(wg)
    00261      enddo
    00262   endif
    00263
    00264   call mficlo(fid,ret)
    00265   !print *,ret
    00266
    00267   call efexit(cret)
    00268
    00269 end program test11
    00270
    00271
    00272 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
    00273   implicit none
    00274   include 'med.hf'
    00275
    00276   integer      ::fid,typcha,ncomp,entite,stockage, ncst
    00277   character(LEN=*)  nomcha
    00278
    00279   integer      :: itm,j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
    00280   integer      :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
    00281   integer,     allocatable, dimension(:) :: pflval
    00282   integer,     allocatable, dimension(:) :: vale
    00283   integer      :: numdt,numo,lnsize,nbrefmaa
    00284   real*8,      allocatable, dimension(:) :: valr
    00285   real*8       dt
    00286   logical      local
    00287   character*64 :: pflname,locname,maa_ass,mname
    00288   character*16 :: dt_unit
    00289   character*255:: lien
    00290   integer       USER_MODE
    00291   integer      :: nmesh,lmesh, mnumdt, mnumit
    00292
    00293   integer,pointer,dimension(:) :: type_geo
    00294   integer,target  :: typ_noeud(1) = (/ MED_NONE /)
    00295
    00296   integer :: MY_NOF_CELL_TYPE = 17
    00297   integer :: MY_NOF_DESCENDING_FACE_TYPE =  5
    00298   integer :: MY_NOF_DESCENDING_EDGE_TYPE =  2
    00299
    00300   integer,target  :: typmai(17) =  (/ MED_POINT1,MED_SEG2,
    00301          MED_SEG3,MED_TRIA3,     &
    00302          MED_QUAD4,MED_TRIA6,    &
    00303          MED_QUAD8,MED_TETRA4,   &
    00304          MED_PYRA5,MED_PENTA6,   &
    00305          MED_HEXA8,MED_TETRA10,  &
    00306          MED_PYRA13,MED_PENTA15,  &
    00307          MED_HEXA20,MED_POLYGON,&
    00308          MED_POLYHEDRON/)
    00309
    00310   integer,target :: typfac(5) = (/MED_TRIA3,MED_TRIA6,
    00311          MED_QUAD4,MED_QUAD8,MED_POLYGON/)
    00312   integer,target ::typare(2) = (/MED_SEG2,MED_SEG3/)
    00313
    00314   character(LEN=15),pointer,dimension(:) :: AFF
    00315   character(LEN=15),target,dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/
    00316          "MED_POINT1     ",&
    00317          "MED_SEG2       ",&
    00318          "MED_SEG3       ",&
    00319          "MED_TRIA3      ",&
    00320          "MED_QUAD4      ",&
    00321          "MED_TRIA6      ",&
    00322          "MED_QUAD8      ",&
    00323          "MED_TETRA4     ",&
    00324          "MED_PYRA5      ",&
    00325          "MED_PENTA6     ",&
    00326          "MED_HEXA8      ",&
    00327          "MED_TETRA10    ",&
    00328          "MED_PYRA13     ",&
    00329          "MED_PENTA15    ",&
    00330          "MED_HEXA20     ",&
    00331          "MED_POLYGON    ",&
    00332          "MED_POLYHEDRON "  /)
    00333
    00334   character(LEN=15),target,dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/
    00335          "MED_TRIA3      ",&
    00336          "MED_TRIA6      ",&
    00337          "MED_QUAD4      ",&
    00338          "MED_QUAD8      ",&
    00339          "MED_POLYGON    " /)
    00340
    00341   character(LEN=15),target,dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/
    00342          "MED_SEG2       ",&
    00343          "MED_SEG3       " /)
    00344
    00345   character(LEN=15),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/
    00346          "(AUCUN)        "/)
    00347
    00348
    00349   character(LEN=20),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/
    00350          "MED_CELL            ", &
    00351          "MED_DESCENDING_FACE ", &
    00352          "MED_DESCENDING_EDGE ", &
    00353          "MED_NODE            ", &
    00354          "MED_NODE_ELEMENT    "/)
    00355
    00356   parameter (USER_MODE = MED_COMPACT_PFLMODE )
    00357
    00358   !!  write (*,'(A0)')  FMED_GEOMETRIE_NOEUD_AFF(1)
    00359   !!  write (*,'(A0)')  FMED_GEOMETRIE_MAILLE_AFF(1)
    00360   !!  write (*,'(A0)')  FMED_GEOMETRIE_FACE_AFF(1)
    00361   !!  write (*,'(A0)')  FMED_GEOMETRIE_ARETE_AFF(1)
    00362
    00363   locname=''
    00364   nbpdtnor=0;pflsize=0;ngauss=0;nent=0
    00365   numdt = 0;numo=0;retmem=0
    00366   cret=0;ret=0
    00367
    00368   nullify(type_geo)
    00369   nullify(AFF)
    00370
    00371
    00372   select case (entite)
    00373   case (MED_NODE)
    00374      type_geo => typ_noeud
    00375      nb_geo   = 1
    00376      AFF      => FMED_GEOMETRIE_NOEUD_AFF
    00377   case (MED_CELL)
    00378      type_geo => typmai
    00379      nb_geo   = 17
    00380      AFF      => FMED_GEOMETRIE_MAILLE_AFF
    00381   case (MED_NODE_ELEMENT)
    00382      type_geo => typmai
    00383      nb_geo   = 17
    00384      AFF      => FMED_GEOMETRIE_MAILLE_AFF
    00385   case (MED_DESCENDING_FACE)
    00386      type_geo => typfac;
    00387      nb_geo   = 5
    00388      AFF      =>  FMED_GEOMETRIE_FACE_AFF
    00389   case  (MED_DESCENDING_EDGE)
    00390      type_geo => typare
    00391      nb_geo   = MY_NOF_DESCENDING_EDGE_TYPE
    00392      AFF      =>  FMED_GEOMETRIE_ARETE_AFF
    00393   end select
    00394
    00395   do k=1,nb_geo
    00396
    00397      ! ** Combien de (PDT,NOR) a lire **
    00398      nbpdtnor = ncst
    00399      if(nbpdtnor < 1 ) continue
    00400
    00401      do j=1,ncst
    00402
    00403         call mfdoci(fid,nomcha,j,numdt,numo,dt, nmesh, mname, lmesh, mnumdt, mnumit, ret)
    00404         ! print *,'ret=',ret
    00405         if (ret.ne.0) then
    00406            print *, "Erreur a la demande d'information sur (pdt,nor) : " &
    00407                 & ,nomcha,entite, numdt, numo, dt
    00408            cret = -1
    00409         end if
    00410
    00411         do itm=1,nmesh
    00412
    00413            call mfdonp(fid,nomcha,numdt,numo,entite,type_geo(k),itm,mname,pflname,locname,nprofile,ret)
    00414            ! print *,'ret=',ret
    00415            if (ret.ne.0) then
    00416               print *, "Erreur a la lecture du nombre de profil : " &
    00417                    & ,nomcha,entite, type_geo(k),numdt, numo
    00418               cret = -1
    00419               call efexit(cret)
    00420            end if
    00421
    00422            do l=1,nprofile
    00423
    00424               ! ** Combien de valeurs à lire ? **
    00425               call mfdonv(fid,nomcha,numdt,numo,entite,type_geo(k),mname,l, &
    00426                      &    USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
    00427
    00428               ! print *,'ret=',ret
    00429               if (ret.ne.0) then
    00430                  print *,"Erreur a la lecture du nombre de valeurs du champ : " &
    00431                       & ,nomcha,entite,type_geo(k), &
    00432                       & numdt, numo
    00433                  cret = -1; continue
    00434               endif
    00435               !write(*,'(5X,A,I5,A)')  'Il y a ', nent ,' valeurs a lire '
    00436
    00437               write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)')  'Séquence de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
    00438               write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
    00439                    & 'Il y a ',nent,' valeurs en mode ',USER_MODE, &
    00440                    & '. Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), &
    00441                    & ' de type geometrique ',TRIM(AFF(k)),' associes au profil |',&
    00442                    & TRIM(pflname)//'| a ',ngauss,' valeur(s) par entité une localization de nom |',TRIM(locname)//'|'
    00443               print *,'Le maillage associe est ', mname
    00444
    00445               ! **Lecture des valeurs du champ **
    00446               if (typcha .eq. MED_FLOAT64) then
    00447                  allocate(valr(ncomp*nent*ngauss),STAT=retmem)
    00448
    00449                  call mfdorr(fid,nomcha,numdt,numo,entite,type_geo(k),mname,USER_MODE, &
    00450                       &      pflname,stockage,MED_ALL_CONSTITUENT,valr,ret)
    00451                  ! print *,'ret=',ret
    00452                  if (ret.ne.0) then
    00453                     print *,"Erreur a la lecture des valeurs du champ : ", &
    00454                          &  nomcha,valr,stockage,MED_ALL_CONSTITUENT, &
    00455                          &  pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00456                     cret = -1;
    00457                     call efexit(cret)
    00458                  endif
    00459               else
    00460                  allocate(vale(ncomp*nent*ngauss),STAT=retmem)
    00461
    00462                  call mfdoir(fid,nomcha,numdt,numo,entite,type_geo(k),mname,USER_MODE, &
    00463                       &      pflname,stockage,MED_ALL_CONSTITUENT,vale,ret)
    00464                  ! print *,'ret=',ret
    00465                  if (ret.ne.0) then
    00466                     print *,"Erreur a la lecture des valeurs du champ : ",&
    00467                          & nomcha,vale,stockage,MED_ALL_CONSTITUENT, &
    00468                          & pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00469                     cret = -1;
    00470                  endif
    00471
    00472               endif
    00473
    00474               if (ngauss .gt. 1 ) then
    00475                  write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
    00476                       & "points de Gauss de nom ", TRIM(locname)
    00477               end if
    00478
    00479               if ( entite .eq. MED_NODE_ELEMENT ) then
    00480                  ngroup = MOD(type_geo(k),100)
    00481               else
    00482                  ngroup = ngauss
    00483               end if
    00484
    00485               select case (stockage)
    00486               case (MED_FULL_INTERLACE)
    00487                  write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00488                  do m=0,nent-1
    00489                     write(*,*) "|"
    00490                     do n=0,(ngroup*ncomp-1)
    00491                        if (typcha .eq. MED_FLOAT64) then
    00492                           write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
    00493                        else
    00494                           write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
    00495                        end if
    00496                     enddo
    00497                  enddo
    00498               case (MED_NO_INTERLACE)
    00499                  write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00500                  do m=0,ncomp-1
    00501                     write(*,*) "|"
    00502                     do n=0,nent-1
    00503                        if (typcha .eq. MED_FLOAT64) then
    00504                           write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
    00505                        else
    00506                           write (*,'(1X,I8,1X)') vale(m*nent+n +1)
    00507                        endif
    00508                     enddo
    00509                  enddo
    00510               end select
    00511
    00512               write(*,*) "|"
    00513               if (typcha .eq. MED_FLOAT64) then
    00514                  deallocate(valr)
    00515               else
    00516                  deallocate(vale)
    00517               endif
    00518
    00519               !* Profils
    00520               if (pflname .eq. MED_NO_PROFILE) then
    00521                  !write(*,'(5X,A)') 'Pas de profil'
    00522               else
    00523                  write(*,'(5X,A,A)') 'Profil :',pflname
    00524                  call mpfpsn(fid,pflname,pflsize,ret)
    00525                  if (ret .ne. 0) then
    00526                     print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
    00527                          & pflname,pflsize
    00528                     cret = -1;continue
    00529                  endif
    00530                  write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
    00531
    00532                  ! ** allocation memoire de pflval **
    00533                  allocate(pflval(pflsize),STAT=retmem)
    00534                  if (retmem .ne. 0) then
    00535                     print *, "Erreur a l'allocation mémoire de pflsize : "
    00536                     call efexit(-1)
    00537                  endif
    00538
    00539                  call mpfprr(fid,pflname,pflval,ret)
    00540                  if (cret .ne. 0) write(*,'(I1)') cret
    00541                  if (ret .ne. 0) then
    00542                     print *,"Erreur a la lecture du profil : ", &
    00543                          & pflname,pflval
    00544                     cret = -1;continue
    00545                  endif
    00546                  write(*,'(5X,A)') 'Valeurs du profil : '
    00547                  do m=1,pflsize
    00548                     write (*,'(5X,I6)') pflval(m)
    00549                  enddo
    00550
    00551                  deallocate(pflval)
    00552
    00553               endif
    00554
    00555            enddo
    00556
    00557         enddo
    00558
    00559      enddo
    00560
    00561   enddo
    00562
    00563
    00564   print *,""
    00565   getFieldsOn=ret
    00566
    00567 end function getFieldsOn