# f/2.3.1/test10.f

    00001 C*  This file is part of MED.
    00002 C*
    00003 C*  COPYRIGHT (C) 1999 - 2012  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