00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
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
00060 argc="test10.med"
00061
00062
00063 call mfiope(fid,argc,MED_ACC_RDONLY, ret)
00064 if (ret .ne. 0) call efexit(-1)
00065
00066
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
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
00089 do i=1,ncha
00090 lret = 0
00091 write(*,'(A,I5)') "- Champ numero : ",i
00092
00093
00094 call mfdnfc(fid,i,ncomp,ret)
00095
00096 if (ret.ne.0) then
00097 print *, "Erreur a la lecture du nombre de composantes : ",ncomp
00098 cret = -1
00099 endif
00100
00101
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
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
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
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
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
00199 end do
00200 endif
00201
00202
00203
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
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
00359
00360
00361
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
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
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
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
00423 call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
00424
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
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
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
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
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
00515 if (pflname .eq. MED_NO_PROFILE) then
00516
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
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