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 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
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
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
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
00198 end do
00199 endif
00200
00201
00202
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
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.hf90'
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
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 mfdoci(fid,nomcha,j,numdt,numo,dt, nmesh, mname, lmesh, mnumdt, mnumit, 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 do itm=1,nmesh
00412
00413 call mfdonp(fid,nomcha,numdt,numo,entite,type_geo(k),itm,mname,pflname,locname,nprofile,ret)
00414
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
00425 call mfdonv(fid,nomcha,numdt,numo,entite,type_geo(k),mname,l, &
00426 & USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
00427
00428
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
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
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
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
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
00520 if (pflname .eq. MED_NO_PROFILE) then
00521
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
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