00001 
00002 
00003 
00004 
00005 
00006 
00007 
00008 
00009 
00010 
00011 
00012 
00013 
00014 
00015 
00016 
00017 
00018 
00019 
00020 
00021 
00022 
00023       program UsesCase_MEDfield_4
00024 
00025       implicit none
00026       include 'med.hf77'
00027 
00028 
00029       integer cret
00030       integer fid
00031 
00032       integer ncompo
00033 
00034       integer ntria3, nquad4
00035 
00036       character*64  fname, lfname
00037 
00038       character*64  mname, finame, cpname, cpunit
00039       character*16 dtunit
00040       real*8 dt
00041       integer ndt, nit
00042 
00043       integer mnumdt, mnumit
00044 
00045       real*8 t3vs1(8)
00046       real*8 t3vs2(8)
00047       real*8 q4vs1(4)
00048       real*8 q4vs2(4)
00049 
00050       parameter (fname = "UsesCase_MEDfield_4.med")
00051       parameter (lfname = "./UsesCase_MEDmesh_1.med")
00052       parameter (mname = "2D unstructured mesh")
00053       parameter (finame = "TEMPERATURE_FIELD")
00054       parameter (cpname ="TEMPERATURE", cpunit = "C")
00055       parameter (dtunit = "ms")
00056       parameter (ncompo = 1 )
00057       parameter (ntria3 =  8, nquad4 = 4)
00058 
00059       data t3vs1 / 1000., 2000., 3000., 4000., 
00060      &             5000., 6000., 7000., 8000. /
00061       data q4vs1 / 10000., 20000., 30000., 4000. /
00062       data t3vs2 / 1500., 2500., 3500., 4500., 
00063      &             5500., 6500., 7500., 8500. /
00064       data q4vs2 / 15000., 25000., 35000., 45000. /
00065 
00066 
00067 
00068       call mfiope(fid,fname,MED_ACC_CREAT,cret)
00069       if (cret .ne. 0 ) then
00070          print *,'ERROR : file creation'
00071          call efexit(-1)
00072       endif  
00073 
00074 
00075 
00076       call mlnliw(fid,mname,lfname,cret)
00077       if (cret .ne. 0 ) then
00078          print *,'ERROR : create mesh link ...'
00079          call efexit(-1)
00080       endif
00081 
00082 
00083 
00084 
00085 
00086       call mfdcre(fid,finame,MED_FLOAT64,ncompo,cpname,cpunit,dtunit,
00087      &            mname,cret)
00088       if (cret .ne. 0 ) then
00089          print *,'ERROR : create field ...'
00090          call efexit(-1)
00091       endif
00092 
00093 
00094 
00095 
00096 
00097 
00098 
00099 
00100 
00101 
00102 
00103 
00104       dt = 5.5d0
00105       ndt = 1
00106       nit = 1
00107       call mfdrvw(fid,finame,ndt,nit,dt,MED_CELL,MED_TRIA3,
00108      &            MED_FULL_INTERLACE,MED_ALL_CONSTITUENT,
00109      &            ntria3,t3vs1,cret)
00110       if (cret .ne. 0 ) then
00111          print *,'ERROR : write field values on MED_TRIA3'
00112          call efexit(-1)
00113       endif
00114 
00115 
00116 
00117       call mfdrvw(fid,finame,ndt,nit,dt,MED_CELL,MED_QUAD4,
00118      &            MED_FULL_INTERLACE,MED_ALL_CONSTITUENT,
00119      &            nquad4,q4vs1,cret)
00120       if (cret .ne. 0 ) then
00121          print *,'ERROR : write field values on MED_TRIA3'
00122          call efexit(-1)
00123       endif
00124 
00125 
00126 
00127 
00128 
00129       dt = 8.9d0
00130       ndt = 2
00131       nit = 1
00132       call mfdrvw(fid,finame,ndt,nit,dt,MED_CELL,MED_TRIA3,
00133      &            MED_FULL_INTERLACE,MED_ALL_CONSTITUENT,
00134      &            ntria3,t3vs2,cret)
00135       if (cret .ne. 0 ) then
00136          print *,'ERROR : write field values on MED_TRIA3'
00137          call efexit(-1)
00138       endif
00139 
00140 
00141 
00142       call mfdrvw(fid,finame,ndt,nit,dt,MED_CELL,MED_QUAD4,
00143      &            MED_FULL_INTERLACE,MED_ALL_CONSTITUENT,
00144      &            nquad4,q4vs2,cret)
00145       if (cret .ne. 0 ) then
00146          print *,'ERROR : write field values on MED_TRIA3'
00147          call efexit(-1)
00148       endif
00149 
00150 
00151 
00152       mnumdt = 1
00153       mnumit = 3
00154       call mfdcmw(fid,finame,ndt,nit,mnumdt,mnumit,cret)
00155       if (cret .ne. 0 ) then
00156          print *,'ERROR : write field mesh computation step error '
00157          call efexit(-1)
00158       endif
00159 
00160 
00161 
00162       call mficlo(fid,cret)
00163       if (cret .ne. 0 ) then
00164          print *,'ERROR :  close file'
00165          call efexit(-1)
00166       endif        
00167 
00168 
00169 
00170       end
00171