f/2.3.1/test10.f

00001 C*  This file is part of MED.
00002 C*
00003 C*  COPYRIGHT (C) 1999 - 2015  EDF R&D, CEA/DEN
00004 C*  MED is free software: you can redistribute it and/or modify
00005 C*  it under the terms of the GNU Lesser General Public License as published by
00006 C*  the Free Software Foundation, either version 3 of the License, or
00007 C*  (at your option) any later version.
00008 C*
00009 C*  MED is distributed in the hope that it will be useful,
00010 C*  but WITHOUT ANY WARRANTY; without even the implied warranty of
00011 C*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00012 C*  GNU Lesser General Public License for more details.
00013 C*
00014 C*  You should have received a copy of the GNU Lesser General Public License
00015 C*  along with MED.  If not, see <http://www.gnu.org/licenses/>.
00016 C*
00017 
00018 C ******************************************************************************
00019 C * - Nom du fichier : test10.f
00020 C *
00021 C * - Description : ecriture de champs de resultats MED 
00022 C *
00023 C ******************************************************************************
00024         program test10
00025 C     
00026         implicit none
00027         include 'med.hf'
00028 C
00029         integer      ret,fid,USER_INTERLACE,USER_MODE
00030         real*8       a,b,p1,p2,dt
00031 
00032         character*32 maa1,maa2,maa3
00033         character*13 lien_maa2
00034 C       CHAMP N°1
00035         character*32 nomcha1
00036         character*16 comp1(2), unit1(2)
00037         character*16 dtunit1, nounit
00038         integer      ncomp1
00039 C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
00040         integer      ngauss1_1
00041         character*32 gauss1_1
00042         real*8       refcoo1(12), gscoo1_1(12), wg1_1(6)
00043         integer      nval1_1
00044         real*8       valr1_1(1*6*2)
00045 C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
00046         integer      ngauss1_2
00047         character*32 gauss1_2
00048         real*8       gscoo1_2(6), wg1_2(3)
00049         integer      nval1_2
00050         real*8       valr1_2(2*3*2)
00051         real*8       valr1_2p(2*3)
00052 C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
00053         integer      ngauss1_3,nval1_3
00054         real*8       valr1_3(2*3*2)
00055         real*8       valr1_3p(2*2)
00056 
00057 C       CHAMP N°2
00058         character*32 nomcha2
00059         character*16 comp2(3), unit2(3)
00060         integer      ncomp2, nval2
00061         integer      valr2(5*3),   valr2p(3*3)
00062 
00063 C       PROFILS UTILISES
00064         character*32 nomprofil1
00065         integer      profil1(2) , profil2(3)
00066 
00067         parameter (USER_INTERLACE = MED_FULL_INTERLACE)
00068         parameter (USER_MODE = MED_COMPACT )
00069         parameter ( a=0.446948490915965D0, b=0.091576213509771D0    )
00070         parameter ( p1=0.11169079483905D0, p2=0.0549758718227661D0  )
00071 C       MAILLAGES
00072         parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
00073         parameter ( lien_maa2= "./testfoo.med"                  )
00074 C       CHAMP N°1
00075         parameter ( nomcha1 = "champ reel" )
00076         parameter ( ncomp1 = 2 )
00077         parameter ( dtunit1 = "                ")
00078         parameter ( nounit  = "                ")
00079 C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
00080         parameter ( gauss1_1 = "Model n1" )
00081         parameter ( ngauss1_1 = 6 )
00082 C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
00083         parameter ( gauss1_2  = "Model n2" )
00084         parameter ( ngauss1_2 = 3 )
00085 C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
00086         parameter ( ngauss1_3 = 6 )
00087         parameter ( nval1_3 = 6 )
00088 C       CHAMP N°2
00089         parameter ( nomcha2="champ entier")
00090         parameter ( ncomp2 = 3, nval2= 5  )
00091 C       PROFILS
00092         parameter ( nomprofil1  = "PROFIL(champ(1))" )
00093         
00094 
00095 C       CHAMP N°1
00096         data comp1 /"comp1", "comp2"/
00097         data unit1 /"unit1","unit2"/
00098 C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
00099         data nval1_1  / 1*6 /
00100         data refcoo1  / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0, 
00101      1                  0.0,-1.0, 0.0,0.0 / 
00102         data valr1_1  /  0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
00103      1                   20.0,21.0, 22.0,23.0/
00104 C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
00105         data valr1_2  / 0.0,1.0, 2.0,3.0, 10.0,11.0,
00106      1                  12.0,13.0, 20.0,21.0, 22.0,23.0 /
00107         data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
00108 C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
00109         data valr1_3  / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0, 
00110      1                  20.0,21.0, 22.0,23.0 /
00111         data valr1_3p / 2.0,3.0, 10.0,11.0   /
00112 C       CHAMP N°2
00113         data comp2 /"comp1", "comp2", "comp3"/
00114         data unit2 /"unit1","unit2", "unit3"/
00115         data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
00116         data valr2p / 0,1,2,           20,21,22,           40,41,42 /
00117 C       PROFILS
00118         data profil1 /2,3/
00119         data profil2 /1,3,5/
00120         
00121         ret = 0
00122 
00123         gscoo1_1(1) =  2*b-1
00124         gscoo1_1(2) =  1-4*b
00125         gscoo1_1(3) =  2*b-1
00126         gscoo1_1(4) =  2*b-1
00127         gscoo1_1(5) =  1-4*b
00128         gscoo1_1(6) =  2*b-1
00129         gscoo1_1(7) =  1-4*a
00130         gscoo1_1(8) =  2*a-1
00131         gscoo1_1(9) =  2*a-1
00132         gscoo1_1(10) =  1-4*a
00133         gscoo1_1(11) =  2*a-1
00134         gscoo1_1(12) =  2*a-1
00135 
00136         wg1_1(1) =  4*p2
00137         wg1_1(2) =  4*p2
00138         wg1_1(3) =  4*p2
00139         wg1_1(4) =  4*p1
00140         wg1_1(5) =  4*p1
00141         wg1_1(6) =  4*p1
00142 
00143         nval1_2 = 2*3
00144         gscoo1_2(1) = -2.0D0/3
00145         gscoo1_2(2) =  1.0D0/3 
00146         gscoo1_2(3) = -2.0D0/3
00147         gscoo1_2(4) = -2.0D0/3
00148         gscoo1_2(5) =  1.0D0/3
00149         gscoo1_2(6) = -2.0D0/3
00150 
00151         wg1_2(1) =  2.0D0/3
00152         wg1_2(2) =  2.0D0/3
00153         wg1_2(3) =  2.0D0/3 
00154                    
00155 C     ** ouverture du fichier                            **
00156         call efouvr(fid,'test10.med',MED_LECTURE_ECRITURE, ret)
00157         if (ret .ne. 0 ) then
00158            print *,'Erreur à l''ouverture du fichier  : ','test10.med'
00159            call efexit(-1)
00160         endif
00161         
00162 C     ** creation du maillage maa1 de dimension 3         **
00163         call efmaac(fid,maa1,3,MED_NON_STRUCTURE,
00164      1                 "Maillage vide",ret)
00165         if (ret .ne. 0 ) then
00166            print *,'Erreur à la création du maillage : ', maa1
00167            call efexit(-1)
00168         endif
00169              
00170 C     ** creation du maillage maa3 de dimension 3         **
00171         call efmaac(fid,maa3,3,MED_NON_STRUCTURE,
00172      1                 "Maillage vide",ret)
00173         if (ret .ne. 0 ) then
00174            print *,'Erreur à la création du maillage : ', maa3
00175            call efexit(-1)
00176         endif
00177              
00178 
00179 C     ** creation du champ réel n°1                        **
00180         call efchac(fid,nomcha1,MED_FLOAT64,comp1,unit1,ncomp1,ret)
00181         if (ret .ne. 0 ) then
00182            print *,'Erreur à la création du champ : ', nomcha1
00183            ret = -1
00184         endif
00185              
00186 C     ** creation du champ entier n°2                      **
00187         call efchac(fid,nomcha2,MED_INT32,comp2,unit2,ncomp2,ret)
00188         if (ret .ne. 0 ) then
00189            print *,'Erreur à la création du champ : ', nomcha2
00190            ret = -1
00191         endif
00192  
00193 C     ** creation du lien au fichier distant contenant maa2 **
00194         call efliee(fid,lien_maa2,maa2,ret)
00195         if (ret .ne. 0 ) then
00196            print *,'Erreur à la création du lien : ', lien_maa2
00197            ret = -1
00198         endif
00199  
00200 C     ** creation de la localisation des points de Gauss modèle n°1 **
00201         call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
00202      1               ngauss1_1, gscoo1_1, wg1_1, gauss1_1, ret)
00203         if (ret .ne. 0 ) then
00204            print *,'Erreur à la création du modèle n°1 : ', gauss1_1
00205            ret = -1
00206         endif
00207 
00208 C     ** creation de la localisation des points de Gauss modèle n°2 **
00209         call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
00210      1               ngauss1_2, gscoo1_2, wg1_2, gauss1_2, ret)
00211         if (ret .ne. 0 ) then
00212            print *,'Erreur à la création du modèle n°2 : ', gauss1_2
00213            ret = -1
00214         endif
00215 
00216         
00217 C     ** Ecriture du champ n°1
00218 C     ** - enregistre uniquement la composante n°2 de valr1_1
00219 C     ** - pas de pas de temps, ni de numero d'ordre
00220         dt = 0.0D0
00221         call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
00222      1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
00223      2               MED_MAILLE,MED_TRIA6,
00224      3               MED_NOPDT,dtunit1,dt,MED_NONOR,ret)
00225         if (ret .ne. 0 ) then
00226            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
00227            ret = -1
00228         endif
00229 
00230 C     ** Nouvelle Ecriture du champ reel en mode remplacement
00231 C     ** - complete le champ precedent en enregistrant les composantes 1
00232 C     ** - pas de pas de temps, ni de numero d'ordre 
00233         call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
00234      1               gauss1_1,1,MED_NOPFL,MED_NO_PFLMOD,
00235      2               MED_MAILLE,MED_TRIA6,
00236      3               MED_NOPDT,dtunit1,dt,MED_NONOR,ret)
00237         if (ret .ne. 0 ) then
00238            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
00239            ret = -1
00240         endif
00241          
00242 C     ** Ecriture sur le champ reel
00243 C     ** - De la 1ere composante du tableau valr1_2
00244 C     ** - Avec un pas de temps égal a 5.5
00245 C     ** - Pas de numero d'ordre
00246 C     ** - maa2 est distant
00247         dt = 5.5D0
00248         call efchae(fid,maa2,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
00249      1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
00250      2               MED_MAILLE,MED_TRIA6,
00251      3               1,"ms",dt,MED_NONOR,ret)
00252         if (ret .ne. 0 ) then
00253            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
00254            ret = -1
00255         endif
00256 
00257 C     ** Ecriture sur le champ reel
00258 C     ** - De la 2ere composante du tableau valr1_2
00259 C     ** - Avec un pas de temps égal a 5.5
00260 C     ** - Pas de numero d'ordre
00261 C     ** - maa1 est local
00262         dt = 5.5D0
00263         call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
00264      1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
00265      2               MED_MAILLE,MED_TRIA6,
00266      3               1,"ms",dt,MED_NONOR,ret)
00267         if (ret .ne. 0 ) then
00268            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
00269            ret = -1
00270         endif
00271 
00272       
00273 C     ** Ecriture sur le champ reel
00274 C     ** - De la 1ere composante du tableau valr1_1
00275 C     ** - Avec un pas de temps égal a 5.5
00276 C     ** - Numero d'ordre egal a 2
00277 C     ** - maa3 est local
00278         dt = 5.5D0
00279         call efchae(fid,maa3,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
00280      1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
00281      2               MED_MAILLE,MED_TRIA6,
00282      3               1,"ms",dt,2,ret)
00283         if (ret .ne. 0 ) then
00284            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
00285            ret = -1
00286         endif
00287     
00288 C     ** Creation de profil
00289 C     ** - qui selectionne uniquement le 2e element du tableau valr1
00290         call efpfle(fid,profil1,1,nomprofil1,ret)
00291         if (ret .ne. 0 ) then
00292            print *,'Erreur à la création du profil : ', nomprofil1
00293            ret = -1
00294         endif
00295 
00296 
00297 C     ** Ecriture du champ reel 
00298 C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
00299 C     ** - Extrait a partir du profil de nom "profil1(1)"
00300 C     ** - Pas de temps = 5.6
00301 C     ** - Numero d'ordre = 2 
00302         dt = 5.6D0
00303         call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
00304      1               MED_NOGAUSS,MED_ALL,nomprofil1,USER_MODE,
00305      2               MED_MAILLE,MED_TRIA6,
00306      3               2,"ms",dt,2,ret)
00307         if (ret .ne. 0 ) then
00308            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
00309            ret = -1
00310         endif
00311 
00312 C     ** Ecriture du champ reel 
00313 C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
00314 C     ** - Extrait a partir du profil de nom "profil1(1)"
00315 C     ** - Pas de temps = 5.6
00316 C     ** - Numero d'ordre = 2 
00317         dt = 5.6D0
00318         call efchae(fid,maa2,nomcha1,valr1_2p,USER_INTERLACE,nval1_2,
00319      1               gauss1_2,MED_ALL,nomprofil1,USER_MODE,
00320      2               MED_MAILLE,MED_TRIA6,
00321      3               2,"ms",dt,2,ret)
00322         if (ret .ne. 0 ) then
00323            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
00324            ret = -1
00325         endif
00326 
00327 
00328 C     ** Ecriture du champ reel 
00329 C     ** - 2e composante du 2e element du champ
00330 C     ** - Extrait a partir du profil de nom "profil1(1)"
00331 C     ** - Pas de temps = 5.7
00332 C     ** - Numero d'ordre = 2 
00333         dt = 5.7D0
00334         call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
00335      1               MED_NOGAUSS,2,nomprofil1,USER_MODE,
00336      2               MED_MAILLE,MED_TRIA6,
00337      3               3,"ms",dt,2,ret)
00338         if (ret .ne. 0 ) then
00339            print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
00340            ret = -1
00341         endif
00342 
00343 
00344 C     ** Ecriture du champ entier n°2
00345 C     ** - 1ere composante des éléments de valr2
00346 C     ** - pas de pas de temps, ni de numero d'ordre
00347         dt = 0.0D0
00348         call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
00349      1     MED_NOGAUSS,1,MED_NOPFL,MED_NO_PFLMOD,MED_ARETE,
00350      1               MED_SEG2,MED_NOPDT,nounit,dt,MED_NONOR,ret)
00351         if (ret .ne. 0 ) then
00352            print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
00353            ret = -1
00354         endif   
00355 
00356 C     ** Ecriture du champ entier n°2
00357 C     ** - 2ere composante des éléments de valr2
00358 C     ** - pas de pas de temps, ni de numero d'ordre
00359 C     ** - pour des raisons de complétude des tests on change 
00360 C     **   le type d'élément (aucun sens phys.))
00361         call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
00362      1     MED_NOGAUSS,2,MED_NOPFL,MED_NO_PFLMOD,MED_NOEUD,
00363      1               0,MED_NOPDT,nounit,dt,MED_NONOR,ret)
00364         if (ret .ne. 0 ) then
00365            print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
00366            ret = -1
00367         endif   
00368 
00369 
00370 C     ** Ecriture du champ entier n°2
00371 C     ** - 3ere composante des éléments de valr2
00372 C     ** - pas de pas de temps, ni de numero d'ordre
00373 C     ** - pour des raisons de complétude des tests on change 
00374 C     **   le type d'élément (aucun sens phys.))
00375         call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
00376      1     MED_NOGAUSS,3,MED_NOPFL,MED_NO_PFLMOD,MED_FACE,
00377      1               MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret)
00378         if (ret .ne. 0 ) then
00379            print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
00380            ret = -1
00381         endif   
00382 
00383 C     ** Creation de profil
00384 C     ** - selectionne les elements 1,3,5 du tableau valr2
00385         call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
00386         if (ret .ne. 0 ) then
00387            print *,'Erreur à l''écriture du profil : ',
00388      1              'profil2(champ2)'
00389            ret = -1
00390         endif   
00391 
00392 
00393 C     ** Ecriture du champ entier n°2
00394 C     ** - 3eme composante des éléments de valr2
00395 C     ** - pas de pas de temps, ni de numero d'ordre
00396 C     ** - profils 
00397 C     ** - pour des raisons de complétude des tests on change 
00398 C     **   le type d'élément (aucun sens phys.))
00399         call efchae(fid,maa1,nomcha2,valr2p,USER_INTERLACE,nval2,
00400      1     MED_NOGAUSS,3,"PROFIL(champ2)",USER_MODE,MED_MAILLE,
00401      1               MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret)
00402         if (ret .ne. 0 ) then
00403            print *,'Erreur à l''écriture du profil : ',
00404      1             'profil2(champ2)'
00405            ret = -1
00406         endif   
00407 
00408 C     ** Fermeture du fichier *
00409         call efferm (fid,ret)
00410         if (ret .ne. 0 ) then
00411            print *,'Erreur à la fermeture du fichier : '
00412            ret = -1
00413         endif   
00414 
00415         print *,"Le code retour : ",ret
00416         call efexit(ret)
00417 
00418         end 
00419 
00420 
00421 

Généré le Thu Oct 8 14:26:16 2015 pour MED fichier par  doxygen 1.6.1