# 2.3.1v3.0/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      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      if (  (index(nomcha,"champ entier") .eq. 1) .and. &
    00128           (len_trim(nomcha) .eq. len("champ entier") )  ) then
    00129
    00130         lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE, USER_INTERLACE, ncst)
    00131         ! print *,lret
    00132
    00133         if (lret .eq. 0) then
    00134            lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_CELL, USER_INTERLACE, ncst)
    00135         else
    00136            print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
    00137         endif
    00138
    00139         if (lret .eq. 0) then
    00140            lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_FACE,USER_INTERLACE, ncst)
    00141         else
    00142            print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
    00143         endif
    00144
    00145         if (lret .eq. 0) then
    00146            lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_EDGE,USER_INTERLACE, ncst)
    00147         else
    00148            print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
    00149         endif
    00150
    00151         if (lret .eq. 0) then
    00152            lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE_ELEMENT,USER_INTERLACE, ncst)
    00153         else
    00154            print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
    00155         endif
    00156
    00157         if  (lret .ne. 0) then
    00158            print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
    00159         endif
    00160      else
    00161         print *, "There is no API yet for reading field on multiple meshes"
    00162      endif
    00163   enddo
    00164
    00165
    00166   call mpfnpf(fid,nval,ret)
    00167   write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
    00168
    00169   if (nval .gt. 0 ) then
    00170      do i=1,nval
    00171            call mpfpfi(fid,i,pflname,nval,ret)
    00172         write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
    00173      enddo
    00174   endif
    00175
    00176
    00177   !  ** Interrogation des liens **
    00178   call mlnnln(fid,nln,ret)
    00179   if (ret.ne.0) then
    00180      print *,"Erreur a la lecture du nombre de liens : " &
    00181           & ,nln
    00182      cret = -1;
    00183   else
    00184      print *,""
    00185      write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
    00186      do i=1,nln
    00187         call mlnlni(fid, i, nomlien, nval, ret)
    00188         if (ret.ne.0) then
    00189            print *,"Erreur a la demande d'information sur le lien n° : ",i
    00190            cret = -1;continue;
    00191         endif
    00192         write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
    00193         !! allocate
    00194         lien = ""
    00195         call mlnlir(fid,nomlien,lien,ret)
    00196         if (ret.ne.0) then
    00197            print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
    00198            ret = -1;
    00199         else
    00200            write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
    00201         endif
    00202         !!deallocate
    00203      end do
    00204   endif
    00205
    00206
    00207   !  ** Interrogation des localisations des points de GAUSS **
    00208   call mlcnlc(fid,nloc,ret)
    00209   if (ret.ne.0) then
    00210      print *,"Erreur a la lecture du nombre de points de Gauss : " &
    00211           & ,nloc
    00212      cret = -1;
    00213   else
    00214      print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
    00215      do i=1,nloc
    00216         call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
    00217         if (ret.ne.0) then
    00218            print *,"Erreur a la demande d'information sur la localisation n° : ",i
    00219            cret = -1;continue;
    00220         endif
    00221         write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
    00222              &,"| et nbr. de pts Gauss ",ngauss,"| et dans un espace de dimension ",sdim
    00223         t1 = MOD(type_geo,100)*sdim
    00224         t2 = ngauss*sdim
    00225         t3 = ngauss
    00226         allocate(refcoo(t1),STAT=retmem)
    00227         if (retmem .ne. 0) then
    00228            print *, "Erreur a l'allocation mémoire de refcoo : "
    00229            call efexit(-1)
    00230         endif;
    00231         allocate(gscoo(t2),STAT=retmem)
    00232         if (retmem .ne. 0) then
    00233            print *, "Erreur a l'allocation mémoire de gscoo : "
    00234            call efexit(-1)
    00235         endif;
    00236         allocate(wg(t3),STAT=retmem)
    00237         if (retmem .ne. 0) then
    00238            print *, "Erreur a l'allocation mémoire de wg : "
    00239            call efexit(-1)
    00240         endif;
    00241         call mlclor(fid, locname,USER_INTERLACE,refcoo,gscoo,wg, ret )
    00242         if (ret.ne.0) then
    00243            print *,"Erreur a la lecture  des valeurs de la localisation : " &
    00244                 & ,locname
    00245            cret = -1;
    00246         else
    00247            write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
    00248            do j=1,t1
    00249               write (*,'(5X,E20.8)') refcoo(j)
    00250            enddo
    00251            print *,""
    00252            write (*,'(5X,A)') "Localisation des points de GAUSS : "
    00253            do j=1,t2
    00254               write (*,'(5X,E20.8)') gscoo(j)
    00255            enddo
    00256            print *,""
    00257            write (*,'(5X,A)') "Poids associes aux points de GAUSS "
    00258            do j=1,t3
    00259               write (*,'(5X,E20.8)') wg(j)
    00260            enddo
    00261            print *,""
    00262         endif
    00263         deallocate(refcoo)
    00264         deallocate(gscoo)
    00265         deallocate(wg)
    00266      enddo
    00267   endif
    00268
    00269   call mficlo(fid,ret)
    00270   !print *,ret
    00271
    00272   call efexit(cret)
    00273
    00274 end program test11
    00275
    00276
    00277 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
    00278   implicit none
    00279   include 'med.hf90'
    00280
    00281   integer      ::fid,typcha,ncomp,entite,stockage, ncst
    00282   character(LEN=*)  nomcha
    00283
    00284   integer      :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
    00285   integer      :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
    00286   integer,     allocatable, dimension(:) :: pflval
    00287   integer,     allocatable, dimension(:) :: vale
    00288   integer      :: numdt,numo,lnsize,nbrefmaa
    00289   real*8,      allocatable, dimension(:) :: valr
    00290   real*8       dt
    00291   logical      local
    00292   character*64 :: pflname,locname,maa_ass
    00293   character*16 :: dt_unit
    00294   character*255:: lien
    00295   integer       USER_MODE
    00296
    00297   integer,pointer,dimension(:) :: type_geo
    00298   integer,target  :: typ_noeud(1) = (/ MED_NONE /)
    00299
    00300   integer :: MY_NOF_CELL_TYPE = 17
    00301   integer :: MY_NOF_DESCENDING_FACE_TYPE =  5
    00302   integer :: MY_NOF_DESCENDING_EDGE_TYPE =  2
    00303
    00304   integer,target  :: typmai(17) =  (/ MED_POINT1,MED_SEG2,
    00305          MED_SEG3,MED_TRIA3,     &
    00306          MED_QUAD4,MED_TRIA6,    &
    00307          MED_QUAD8,MED_TETRA4,   &
    00308          MED_PYRA5,MED_PENTA6,   &
    00309          MED_HEXA8,MED_TETRA10,  &
    00310          MED_PYRA13,MED_PENTA15,  &
    00311          MED_HEXA20,MED_POLYGON,&
    00312          MED_POLYHEDRON/)
    00313
    00314   integer,target :: typfac(5) = (/MED_TRIA3,MED_TRIA6,
    00315          MED_QUAD4,MED_QUAD8,MED_POLYGON/)
    00316   integer,target ::typare(2) = (/MED_SEG2,MED_SEG3/)
    00317
    00318   character(LEN=15),pointer,dimension(:) :: AFF
    00319   character(LEN=15),target,dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/
    00320          "MED_POINT1     ",&
    00321          "MED_SEG2       ",&
    00322          "MED_SEG3       ",&
    00323          "MED_TRIA3      ",&
    00324          "MED_QUAD4      ",&
    00325          "MED_TRIA6      ",&
    00326          "MED_QUAD8      ",&
    00327          "MED_TETRA4     ",&
    00328          "MED_PYRA5      ",&
    00329          "MED_PENTA6     ",&
    00330          "MED_HEXA8      ",&
    00331          "MED_TETRA10    ",&
    00332          "MED_PYRA13     ",&
    00333          "MED_PENTA15    ",&
    00334          "MED_HEXA20     ",&
    00335          "MED_POLYGON    ",&
    00336          "MED_POLYHEDRON "  /)
    00337
    00338   character(LEN=15),target,dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/
    00339          "MED_TRIA3      ",&
    00340          "MED_TRIA6      ",&
    00341          "MED_QUAD4      ",&
    00342          "MED_QUAD8      ",&
    00343          "MED_POLYGON    " /)
    00344
    00345   character(LEN=15),target,dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/
    00346          "MED_SEG2       ",&
    00347          "MED_SEG3       " /)
    00348
    00349   character(LEN=15),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/
    00350          "(AUCUN)        "/)
    00351
    00352
    00353   character(LEN=20),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/
    00354          "MED_CELL            ", &
    00355          "MED_DESCENDING_FACE ", &
    00356          "MED_DESCENDING_EDGE ", &
    00357          "MED_NODE            ", &
    00358          "MED_NODE_ELEMENT    "/)
    00359
    00360   parameter (USER_MODE = MED_COMPACT_PFLMODE )
    00361
    00362   !!  write (*,'(A0)')  FMED_GEOMETRIE_NOEUD_AFF(1)
    00363   !!  write (*,'(A0)')  FMED_GEOMETRIE_MAILLE_AFF(1)
    00364   !!  write (*,'(A0)')  FMED_GEOMETRIE_FACE_AFF(1)
    00365   !!  write (*,'(A0)')  FMED_GEOMETRIE_ARETE_AFF(1)
    00366
    00367   locname=''
    00368   nbpdtnor=0;pflsize=0;ngauss=0;nent=0
    00369   numdt = 0;numo=0;retmem=0
    00370   cret=0;ret=0
    00371
    00372   nullify(type_geo)
    00373   nullify(AFF)
    00374
    00375
    00376   select case (entite)
    00377   case (MED_NODE)
    00378      type_geo => typ_noeud
    00379      nb_geo   = 1
    00380      AFF      => FMED_GEOMETRIE_NOEUD_AFF
    00381   case (MED_CELL)
    00382      type_geo => typmai
    00383      nb_geo   = 17
    00384      AFF      => FMED_GEOMETRIE_MAILLE_AFF
    00385   case (MED_NODE_ELEMENT)
    00386      type_geo => typmai
    00387      nb_geo   = 17
    00388      AFF      => FMED_GEOMETRIE_MAILLE_AFF
    00389   case (MED_DESCENDING_FACE)
    00390      type_geo => typfac;
    00391      nb_geo   = 5
    00392      AFF      =>  FMED_GEOMETRIE_FACE_AFF
    00393   case  (MED_DESCENDING_EDGE)
    00394      type_geo => typare
    00395      nb_geo   = MY_NOF_DESCENDING_EDGE_TYPE
    00396      AFF      =>  FMED_GEOMETRIE_ARETE_AFF
    00397   end select
    00398
    00399   do k=1,nb_geo
    00400
    00401      ! ** Combien de (PDT,NOR) a lire **
    00402      nbpdtnor = ncst
    00403      if(nbpdtnor < 1 ) continue
    00404
    00405      do j=1,ncst
    00406
    00407         call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
    00408         !print *,ret
    00409         if (ret.ne.0) then
    00410            print *, "Erreur a la demande d'information sur (pdt,nor) : " &
    00411                 & ,nomcha,entite, numdt, numo, dt
    00412            cret = -1
    00413         end if
    00414
    00415         call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
    00416         !print *,ret
    00417         if (ret.ne.0) then
    00418            print *, "Erreur a la lecture du nombre de profil : " &
    00419                 & ,nomcha,entite, type_geo(k),numdt, numo
    00420            cret = -1
    00421            call efexit(cret)
    00422         end if
    00423
    00424         do l=1,nprofile
    00425
    00426            ! ** Combien de valeurs à lire ? **
    00427            call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
    00428            !print *,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é, et une localization de nom |',TRIM(locname)//'|'
    00443
    00444            ! **Lecture des valeurs du champ **
    00445            if (typcha .eq. MED_FLOAT64) then
    00446               allocate(valr(ncomp*nent*ngauss),STAT=retmem)
    00447
    00448               call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
    00449                    &      pflname,stockage,MED_ALL_CONSTITUENT,valr,ret)
    00450               !print *,ret
    00451               if (ret.ne.0) then
    00452                  print *,"Erreur a la lecture des valeurs du champ : ", &
    00453                       &  nomcha,valr,stockage,MED_ALL_CONSTITUENT, &
    00454                       &  pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00455                  cret = -1;
    00456                  call efexit(cret)
    00457               endif
    00458            else
    00459               allocate(vale(ncomp*nent*ngauss),STAT=retmem)
    00460
    00461               call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
    00462                    &      pflname,stockage,MED_ALL_CONSTITUENT,vale,ret)
    00463               !print *,ret
    00464               if (ret.ne.0) then
    00465                  print *,"Erreur a la lecture des valeurs du champ : ",&
    00466                       & nomcha,vale,stockage,MED_ALL_CONSTITUENT, &
    00467                       & pflname,USER_MODE,entite,type_geo(k),numdt,numo
    00468                  cret = -1;
    00469               endif
    00470
    00471            endif
    00472
    00473            if (ngauss .gt. 1 ) then
    00474               write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
    00475                    & "points de Gauss de nom ", TRIM(locname)
    00476            end if
    00477
    00478            if ( entite .eq. MED_NODE_ELEMENT ) then
    00479               ngroup = MOD(type_geo(k),100)
    00480            else
    00481               ngroup = ngauss
    00482            end if
    00483
    00484            select case (stockage)
    00485            case (MED_FULL_INTERLACE)
    00486               write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00487               do m=0,nent-1
    00488                  write(*,*) "|"
    00489                  do n=0,(ngroup*ncomp-1)
    00490                     if (typcha .eq. MED_FLOAT64) then
    00491                        write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
    00492                     else
    00493                        write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
    00494                     end if
    00495                  enddo
    00496               enddo
    00497            case (MED_NO_INTERLACE)
    00498               write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
    00499               do m=0,ncomp-1
    00500                  write(*,*) "|"
    00501                  do n=0,nent-1
    00502                     if (typcha .eq. MED_FLOAT64) then
    00503                        write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
    00504                     else
    00505                        write (*,'(1X,I8,1X)') vale(m*nent+n +1)
    00506                     endif
    00507                  enddo
    00508               enddo
    00509            end select
    00510
    00511            write(*,*) "|"
    00512            if (typcha .eq. MED_FLOAT64) then
    00513               deallocate(valr)
    00514            else
    00515               deallocate(vale)
    00516            endif
    00517
    00518            !* Profils
    00519            if (pflname .eq. MED_NO_PROFILE) then
    00520               !write(*,'(5X,A)') 'Pas de profil'
    00521            else
    00522               write(*,'(5X,A,A)') 'Profil :',pflname
    00523               call mpfpsn(fid,pflname,pflsize,ret)
    00524               if (ret .ne. 0) then
    00525                  print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
    00526                       & pflname,pflsize
    00527                  cret = -1;continue
    00528               endif
    00529               write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
    00530
    00531               ! ** allocation memoire de pflval **
    00532               allocate(pflval(pflsize),STAT=retmem)
    00533               if (retmem .ne. 0) then
    00534                  print *, "Erreur a l'allocation mémoire de pflsize : "
    00535                  call efexit(-1)
    00536               endif
    00537
    00538               call mpfprr(fid,pflname,pflval,ret)
    00539               if (cret .ne. 0) write(*,'(I1)') cret
    00540               if (ret .ne. 0) then
    00541                  print *,"Erreur a la lecture du profil : ", &
    00542                       & pflname,pflval
    00543                  cret = -1;continue
    00544               endif
    00545               write(*,'(5X,A)') 'Valeurs du profil : '
    00546               do m=1,pflsize
    00547                  write (*,'(5X,I6)') pflval(m)
    00548               enddo
    00549
    00550               deallocate(pflval)
    00551
    00552            endif
    00553
    00554         enddo
    00555
    00556      enddo
    00557
    00558   enddo
    00559
    00560   print *,""
    00561   getFieldsOn=ret
    00562
    00563 end function getFieldsOn