# test11.f90

Aller à la documentation de ce fichier.

    00001 !*  This file is part of MED.
    00002 !*
    00003 !*  COPYRIGHT (C) 1999 - 2012  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.hf90'
    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      write(*,'(5X,A,I1)') 'Nombre de composantes = ',ncomp
    00120      do j=1,ncomp
    00121         write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,'  : ',TRIM(comp(j)),' ',TRIM(unit(j))
    00122      enddo
    00123      write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
    00124      print *,""
    00125
    00126      deallocate(comp,unit)
    00127
    00128      lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE, USER_INTERLACE, ncst)
    00129      ! print *,lret
    00130
    00131      if (lret .eq. 0) then
    00132         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_CELL, USER_INTERLACE, ncst)
    00133      else
    00134         print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
    00135      endif
    00136
    00137      if (lret .eq. 0) then
    00138         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_FACE,USER_INTERLACE, ncst)
    00139      else
    00140         print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
    00141      endif
    00142
    00143      if (lret .eq. 0) then
    00144         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_EDGE,USER_INTERLACE, ncst)
    00145      else
    00146         print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
    00147      endif
    00148
    00149      if (lret .eq. 0) then
    00150         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE_ELEMENT,USER_INTERLACE, ncst)
    00151      else
    00152         print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
    00153      endif
    00154
    00155      if  (lret .ne. 0) then
    00156         print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
    00157      endif
    00158
    00159   enddo
    00160
    00161
    00162   call mpfnpf(fid,nval,ret)
    00163   write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
    00164
    00165   if (nval .gt. 0 ) then
    00166      do i=1,nval
    00167            call mpfpfi(fid,i,pflname,nval,ret)
    00168         write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
    00169      enddo
    00170   endif
    00171
    00172
    00173   !  ** Interrogation des liens **
    00174   call mlnnln(fid,nln,ret)
    00175   if (ret.ne.0) then
    00176      print *,"Erreur a la lecture du nombre de liens : " &
    00177           & ,nln
    00178      cret = -1;
    00179   else
    00180      print *,""
    00181      write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
    00182      do i=1,nln
    00183         call mlnlni(fid, i, nomlien, nval, ret)
    00184         if (ret.ne.0) then
    00185            print *,"Erreur a la demande d'information sur le lien n° : ",i
    00186            cret = -1;continue;
    00187         endif
    00188         write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
    00189         !! allocate
    00190         lien = ""
    00191         call mlnlir(fid,nomlien,lien,ret)
    00192         if (ret.ne.0) then
    00193            print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
    00194            ret = -1;
    00195         else
    00196            write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
    00197         endif
    00198         !!deallocate
    00199      end do
    00200   endif
    00201
    00202
    00203   !  ** Interrogation des localisations des points de GAUSS **
    00204   call mlcnlc(fid,nloc,ret)
    00205   if (ret.ne.0) then
    00206      print *,"Erreur a la lecture du nombre de points de Gauss : " &
    00207           & ,nloc
    00208      cret = -1;
    00209   else
    00210      print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
    00211      do i=1,nloc
    00212         call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
    00213         if (ret.ne.0) then
    00214            print *,"Erreur a la demande d'information sur la localisation n° : ",i
    00215            cret = -1;continue;
    00216         endif
    00217         write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
    00218              &,"| et nbr. de pts Gauss ",ngauss,"| et dans un espace de dimension ",sdim
    00219         t1 = MOD(type_geo,100)*sdim
    00220         t2 = ngauss*sdim
    00221         t3 = ngauss
    00222         allocate(refcoo(t1),STAT=retmem)
    00223         if (retmem .ne. 0) then
    00224            print *, "Erreur a l'allocation mémoire de refcoo : "
    00225            call efexit(-1)
    00226         endif;
    00227         allocate(gscoo(t2),STAT=retmem)
    00228         if (retmem .ne. 0) then
    00229            print *, "Erreur a l'allocation mémoire de gscoo : "
    00230            call efexit(-1)
    00231         endif;
    00232         allocate(wg(t3),STAT=retmem)
    00233         if (retmem .ne. 0) then
    00234            print *, "Erreur a l'allocation mémoire de wg : "
    00235            call efexit(-1)
    00236         endif;
    00237         call mlclor(fid, locname,USER_INTERLACE,refcoo,gscoo,wg, ret )
    00238         if (ret.ne.0) then
    00239            print *,"Erreur a la lecture  des valeurs de la localisation : " &
    00240                 & ,locname
    00241            cret = -1;
    00242         else
    00243            write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
    00244            do j=1,t1
    00245               write (*,'(5X,E20.8)') refcoo(j)
    00246            enddo
    00247            print *,""
    00248            write (*,'(5X,A)') "Localisation des points de GAUSS : "
    00249            do j=1,t2
    00250               write (*,'(5X,E20.8)') gscoo(j)
    00251            enddo
    00252            print *,""
    00253            write (*,'(5X,A)') "Poids associes aux points de GAUSS "
    00254            do j=1,t3
    00255               write (*,'(5X,E20.8)') wg(j)
    00256            enddo
    00257            print *,""
    00258         endif
    00259         deallocate(refcoo)
    00260         deallocate(gscoo)
    00261         deallocate(wg)
    00262      enddo
    00263   endif
    00264
    00265   call mficlo(fid,ret)
    00266   !print *,ret
    00267
    00268   call efexit(cret)
    00269
    00270 end program test11
    00271
    00272
    00273 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
    00274   implicit none
    00275   include 'med.hf90'
    00276
    00277   integer      ::fid,typcha,ncomp,entite,stockage, ncst
    00278   character(LEN=*)  nomcha
    00279
    00280   integer      :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
    00281   integer      :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
    00282   integer,     allocatable, dimension(:) :: pflval
    00283   integer,     allocatable, dimension(:) :: vale
    00284   integer      :: numdt,numo,lnsize,nbrefmaa
    00285   real*8,      allocatable, dimension(:) :: valr
    00286   real*8       dt
    00287   logical      local
    00288   character*64 :: pflname,locname,maa_ass
    00289   character*16 :: dt_unit
    00290   character*255:: lien
    00291   integer       USER_MODE
    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 mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
    00404         !print *,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         call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
    00412         !print *,ret
    00413         if (ret.ne.0) then
    00414            print *, "Erreur a la lecture du nombre de profil : " &
    00415                 & ,nomcha,entite, type_geo(k),numdt, numo
    00416            cret = -1
    00417            call efexit(cret)
    00418         end if
    00419
    00420         do l=1,nprofile
    00421
    00422            ! ** Combien de valeurs à lire ? **
    00423            call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
    00424            !print *,ret
    00425            if (ret.ne.0) then
    00426               print *,"Erreur a la lecture du nombre de valeurs du champ : " &
    00427                    & ,nomcha,entite,type_geo(k), &
    00428                    & numdt, numo
    00429               cret = -1; continue
    00430            endif
    00431            !write(*,'(5X,A,I5,A)')  'Il y a ', nent ,' valeurs a lire '
    00432
    00433            write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)')  'Séquence de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
    00434            write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
    00435                 & 'Il y a ',nent,' valeurs en mode ',USER_MODE, &
    00436                 & '. Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), &
    00437                 & ' de type geometrique ',TRIM(AFF(k)),' associes au profil |',&
    00438                 & TRIM(pflname)//'| a ',ngauss,' valeur(s) par entité, et une localization de nom |',TRIM(locname)//'|'
    00439
    00440            ! **Lecture des valeurs du champ **
    00441            if (typcha .eq. MED_FLOAT64) then
    00442               allocate(valr(ncomp*nent*ngauss),STAT=retmem)
    00443
    00444               call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
    00445                    &      pflname,stockage,MED_ALL_CONSTITUENT,valr,ret)
    00446               !print *,ret
    00447               if (ret.ne.0) then
    00448                  print *,"Erreur a la lecture des valeurs du champ : ", &
    00449                       &  nomcha,valr,stockage,MED_ALL_CONSTITUENT, &
    00450                       &  pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00451                  cret = -1;
    00452                  call efexit(cret)
    00453               endif
    00454            else
    00455               allocate(vale(ncomp*nent*ngauss),STAT=retmem)
    00456
    00457               call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
    00458                    &      pflname,stockage,MED_ALL_CONSTITUENT,vale,ret)
    00459               !print *,ret
    00460               if (ret.ne.0) then
    00461                  print *,"Erreur a la lecture des valeurs du champ : ",&
    00462                       & nomcha,vale,stockage,MED_ALL_CONSTITUENT, &
    00463                       & pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00464                  cret = -1;
    00465               endif
    00466
    00467            endif
    00468
    00469            if (ngauss .gt. 1 ) then
    00470               write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
    00471                    & "points de Gauss de nom ", TRIM(locname)
    00472            end if
    00473
    00474            if ( entite .eq. MED_NODE_ELEMENT ) then
    00475               ngroup = MOD(type_geo(k),100)
    00476            else
    00477               ngroup = ngauss
    00478            end if
    00479
    00480            select case (stockage)
    00481            case (MED_FULL_INTERLACE)
    00482               write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00483               do m=0,nent-1
    00484                  write(*,*) "|"
    00485                  do n=0,(ngroup*ncomp-1)
    00486                     if (typcha .eq. MED_FLOAT64) then
    00487                        write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
    00488                     else
    00489                        write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
    00490                     end if
    00491                  enddo
    00492               enddo
    00493            case (MED_NO_INTERLACE)
    00494               write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00495               do m=0,ncomp-1
    00496                  write(*,*) "|"
    00497                  do n=0,nent-1
    00498                     if (typcha .eq. MED_FLOAT64) then
    00499                        write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
    00500                     else
    00501                        write (*,'(1X,I8,1X)') vale(m*nent+n +1)
    00502                     endif
    00503                  enddo
    00504               enddo
    00505            end select
    00506
    00507            write(*,*) "|"
    00508            if (typcha .eq. MED_FLOAT64) then
    00509               deallocate(valr)
    00510            else
    00511               deallocate(vale)
    00512            endif
    00513
    00514            !* Profils
    00515            if (pflname .eq. MED_NO_PROFILE) then
    00516               !write(*,'(5X,A)') 'Pas de profil'
    00517            else
    00518               write(*,'(5X,A,A)') 'Profil :',pflname
    00519               call mpfpsn(fid,pflname,pflsize,ret)
    00520               if (ret .ne. 0) then
    00521                  print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
    00522                       & pflname,pflsize
    00523                  cret = -1;continue
    00524               endif
    00525               write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
    00526
    00527               ! ** allocation memoire de pflval **
    00528               allocate(pflval(pflsize),STAT=retmem)
    00529               if (retmem .ne. 0) then
    00530                  print *, "Erreur a l'allocation mémoire de pflsize : "
    00531                  call efexit(-1)
    00532               endif
    00533
    00534               call mpfprr(fid,pflname,pflval,ret)
    00535               if (cret .ne. 0) write(*,'(I1)') cret
    00536               if (ret .ne. 0) then
    00537                  print *,"Erreur a la lecture du profil : ", &
    00538                       & pflname,pflval
    00539                  cret = -1;continue
    00540               endif
    00541               write(*,'(5X,A)') 'Valeurs du profil : '
    00542               do m=1,pflsize
    00543                  write (*,'(5X,I6)') pflval(m)
    00544               enddo
    00545
    00546               deallocate(pflval)
    00547
    00548            endif
    00549
    00550         enddo
    00551
    00552      enddo
    00553
    00554   enddo
    00555
    00556   print *,""
    00557   getFieldsOn=ret
    00558
    00559 end function getFieldsOn