      1  C*************************************************************************
      2  C COPYRIGHT (C) 1999 - 2003  EDF R&D
      3  C THIS LIBRARY IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY
      4  C IT UNDER THE TERMS OF THE GNU LESSER GENERAL PUBLIC LICENSE
      5  C AS PUBLISHED BY THE FREE SOFTWARE FOUNDATION;
      6  C EITHER VERSION 2.1 OF THE LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION.
      7  C
      8  C THIS LIBRARY IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL, BUT
      9  C WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF
     10  C MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU
     11  C LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS.
     12  C
     13  C YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER GENERAL PUBLIC LICENSE
     14  C ALONG WITH THIS LIBRARY; IF NOT, WRITE TO THE FREE SOFTWARE FOUNDATION,
     15  C INC., 59 TEMPLE PLACE, SUITE 330, BOSTON, MA 02111-1307 USA
     16  C
     17  C**************************************************************************
     18
     19  C ******************************************************************************
     20  C * - Nom du fichier : test10.f
     21  C *
     22  C * - Description : ecriture de champs de resultats MED
     23  C *
     24  C ******************************************************************************
     25      program test10
     26  C
     27      implicit none
     28      include 'med.hf'
     29  C
     30      integer      ret,fid,USER_INTERLACE,USER_MODE
     31      real*8       a,b,p1,p2,dt
     32
     33      character*32 maa1,maa2,maa3
     34      character*13 lien_maa2
     35  C       CHAMP N°1
     36      character*32 nomcha1
     37      integer      mdim
     38      character*16 comp1(2), unit1(2)
     39      character*16 dtunit1
     40      integer      ncomp1
     41  C   MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
     42      integer      ngauss1_1
     43      character*32 gauss1_1
     44      real*8       refcoo1(12), gscoo1_1(12), wg1_1(6)
     45      integer      nval1_1
     46      real*8       valr1_1(1*6*2)
     47  C   MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
     48      integer      ngauss1_2
     49      character*32 gauss1_2
     50      real*8       gscoo1_2(6), wg1_2(3)
     51      integer      nval1_2
     52      real*8       valr1_2(2*3*2)
     53      real*8       valr1_2p(2*3)
     54  C   MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
     55      integer      ngauss1_3,nval1_3
     56      real*8       valr1_3(2*3*2)
     57      real*8       valr1_3p(2*2)
     58
     59  C   CHAMP N°2
     60      character*32 nomcha2
     61      character*16 comp2(3), unit2(3)
     62      integer      ncomp2, nval2
     63      integer      valr2(5*3),   valr2p(3*3)
     64
     65  C   PROFILS UTILISES
     66      character*32 nomprofil1
     67      integer      profil1(2) , profil2(3)
     68
     69      parameter (USER_INTERLACE = MED_FULL_INTERLACE)
     70      parameter (USER_MODE = MED_COMPACT )
     71      parameter ( a=0.446948490915965, b=0.091576213509771    )
     72      parameter ( p1=0.11169079483905, p2=0.0549758718227661  )
     73  C       MAILLAGES
     74      parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
     75      parameter ( lien_maa2= "./testfoo.med"                  )
     76  C       CHAMP N°1
     77      parameter ( nomcha1 = "champ reel" )
     78      parameter ( ncomp1 = 2 )
     79      parameter ( dtunit1 = "")
     80  C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
     81      parameter ( gauss1_1 = "Model n1" )
     82      parameter ( ngauss1_1 = 6 )
     83  C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
     84      parameter ( gauss1_2  = "Model n2" )
     85      parameter ( ngauss1_2 = 3 )
     86  C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
     87      parameter ( ngauss1_3 = 6 )
     88      parameter ( nval1_3 = 6 )
     89  C       CHAMP N°2
     90      parameter ( nomcha2="champ entier")
     91          parameter ( ncomp2 = 3, nval2= 5  )
     92  C       PROFILS
     93      parameter ( nomprofil1  = "PROFIL(champ(1))" )
     94
     95
     96  C       CHAMP N°1
     97      data comp1 /"comp1", "comp2"/
     98          data unit1 /"unit1","unit2"/
     99  C       MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
    100      data nval1_1  / 1*6 /
    101      data refcoo1  / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
    102       1                0.0,-1.0, 0.0,0.0 /
    103      data valr1_1  /  0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
    104       1                   20.0,21.0, 22.0,23.0/
    105  C       MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
    106      data valr1_2  / 0.0,1.0, 2.0,3.0, 10.0,11.0,
    107       1                  12.0,13.0, 20.0,21.0, 22.0,23.0 /
    108      data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
    109  C       MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
    110      data valr1_3  / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
    111       1                  20.0,21.0, 22.0,23.0 /
    112      data valr1_3p / 2.0,3.0, 10.0,11.0   /
    113  C       CHAMP N°2
    114      data comp2 /"comp1", "comp2", "comp3"/
    115          data unit2 /"unit1","unit2", "unit3"/
    116      data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
    117      data valr2p / 0,1,2,           20,21,22,           40,41,42 /
    118  C       PROFILS
    119      data profil1 /2,3/
    120      data profil2 /1,3,5/
    121
    122      ret = 0
    123
    124      gscoo1_1(1) =  2*b-1
    125      gscoo1_1(2) =  1-4*b
    126      gscoo1_1(3) =  2*b-1
    127      gscoo1_1(4) =  2*b-1
    128      gscoo1_1(5) =  1-4*b
    129      gscoo1_1(6) =  2*b-1
    130      gscoo1_1(7) =  1-4*a
    131      gscoo1_1(8) =  2*a-1
    132      ygscoo1_1(9) =  2*a-1
    133      gscoo1_1(10) =  1-4*a
    134      gscoo1_1(11) =  2*a-1
    135      gscoo1_1(12) =  2*a-1
    136
    137      wg1_1(1) =  4*p2
    138      wg1_1(2) =  4*p2
    139      wg1_1(3) =  4*p2
    140      wg1_1(4) =  4*p1
    141      wg1_1(5) =  4*p1
    142      wg1_1(6) =  4*p1
    143
    144      nval1_2 = 2*3
    145      gscoo1_2(1) = -2.0/3
    146      gscoo1_2(2) =  1.0/3
    147      gscoo1_2(3) = -2.0/3
    148      gscoo1_2(4) = -2.0/3
    149      gscoo1_2(5) =  1.0/3
    150      gscoo1_2(6) = -2.0/3
    151
    152      wg1_2(1) =  2.0/3
    153      wg1_2(2) =  2.0/3
    154      wg1_2(3) =  2.0/3
    155
    156  C     ** ouverture du fichier                            **
    157      call efouvr(fid,'test10.med',MED_CREATION, ret)
    158      if (ret .ne. 0 ) then
    159          print *,'Erreur à l''ouverture du fichier  : ','test10.med'
    160          call efexit(-1)
    161      endif
    162
    163  C     ** creation du maillage maa1 de dimension 3         **
    164      call efmaac(fid,maa1,3,MED_NON_STRUCTURE,
    165      1               "Maillage vide",ret)
    166      if (ret .ne. 0 ) then
    167          print *,'Erreur à la création du maillage : ', maa1
    168          call efexit(-1)
    169      endif
    170
    171  C     ** creation du maillage maa3 de dimension 3         **
    172      call efmaac(fid,maa3,3,MED_NON_STRUCTURE,
    173       1              "Maillage vide",ret)
    174      if (ret .ne. 0 ) then
    175         print *,'Erreur à la création du maillage : ', maa3
    176         call efexit(-1)
    177      endif
    178
    179
    180  C     ** creation du champ réel n°1                        **
    181      call efchac(fid,nomcha1,MED_FLOAT64,comp1,unit1,ncomp1,ret)
    182      if (ret .ne. 0 ) then
    183         print *,'Erreur à la création du champ : ', nomcha1
    184         ret = -1
    185      endif
    186
    187  C     ** creation du champ entier n°2                      **
    188      call efchac(fid,nomcha2,MED_INT32,comp2,unit2,ncomp2,ret)
    189      if (ret .ne. 0 ) then
    190         print *,'Erreur à la création du champ : ', nomcha2
    191         ret = -1
    192      endif
    193
    194  C     ** creation du lien au fichier distant contenant maa2 **
    195      call efliee(fid,lien_maa2,maa2,ret)
    196      if (ret .ne. 0 ) then
    197         print *,'Erreur à la création du lien : ', lien_maa2
    198         ret = -1
    199      endif
    200
    201  C     ** creation de la localisation des points de Gauss modèle n°1 **
    202      call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
    203      1             ngauss1_1, gscoo1_1, wg1_1, gauss1_1, ret)
    204      if (ret .ne. 0 ) then
    205         print *,'Erreur à la création du modèle n°1 : ', gauss1_1
    206         ret = -1
    207      endif
    208
    209  C     ** creation de la localisation des points de Gauss modèle n°2 **
    210      call efgaue(fid, MED_TRIA6, refcoo1, USER_INTERLACE,
    211      1            ngauss1_2, gscoo1_2, wg1_2, gauss1_2, ret)
    212      if (ret .ne. 0 ) then
    213         print *,'Erreur à la création du modèle n°2 : ', gauss1_2
    214         ret = -1
    215      endif
    216
    217
    218  C     ** Ecriture du champ 1
    219  C     ** - enregistre uniquement la composante 2 de valr1_1
    220  C     ** - pas de pas de temps, ni de numero d ordre
    221      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
    222      1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
    223      2               MED_MAILLE,MED_TRIA6,
    224      3               MED_NOPDT,dtunit1,0.0,MED_NONOR,ret)
    225      if (ret .ne. 0 ) then
    226         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
    227         ret = -1
    228      endif
    229
    230  C     ** Nouvelle Ecriture du champ reel en mode remplacement
    231  C     ** - complete le champ precedent en enregistrant les composantes 1
    232  C     ** - pas de pas de temps, ni de numero d ordre
    233      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
    234      1               gauss1_1,1,MED_NOPFL,MED_NO_PFLMOD,
    235      2               MED_MAILLE,MED_TRIA6,
    236      3               MED_NOPDT,dtunit1,0.0,MED_NONOR,ret)
    237      if (ret .ne. 0 ) then
    238         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
    239         ret = -1
    240      endif
    241
    242  C     ** Ecriture sur le champ reel
    243  C     ** - De la 1ere composante du tableau valr1_2
    244  C     ** - Avec un pas de temps égal a 5.5
    245  C     ** - Pas de numero d ordre
    246  C     ** - maa2 est distant
    247      dt = 5.5
    248      call efchae(fid,maa2,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
    249       1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
    250       2               MED_MAILLE,MED_TRIA6,
    251       3               1,"ms",dt,MED_NONOR,ret)
    252      if (ret .ne. 0 ) then
    253         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
    254         ret = -1
    255      endif
    256
    257  C     ** Ecriture sur le champ reel
    258  C     ** - De la 2ere composante du tableau valr1_2
    259  C     ** - Avec un pas de temps égal a 5.5
    260  C     ** - Pas de numero d ordre
    261  C     ** - maa1 est local
    262      dt = 5.5
    263      call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1,
    264       1               gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD,
    265       2               MED_MAILLE,MED_TRIA6,
    266       3               1,"ms",dt,MED_NONOR,ret)
    267      if (ret .ne. 0 ) then
    268         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
    269         ret = -1
    270      endif
    271
    272
    273  C     ** Ecriture sur le champ reel
    274  C     ** - De la 1ere composante du tableau valr1_1
    275  C     ** - Avec un pas de temps égal a 5.5
    276  C     ** - Numero d ordre egal a 2
    277  C     ** - maa3 est local
    278      dt = 5.5
    279      call efchae(fid,maa3,nomcha1,valr1_2,USER_INTERLACE,nval1_2,
    280       1               gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD,
    281       2               MED_MAILLE,MED_TRIA6,
    282       3               1,"ms",dt,2,ret)
    283      if (ret .ne. 0 ) then
    284         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
    285         ret = -1
    286      endif
    287
    288  C     ** Creation de profil
    289  C     ** - qui selectionne uniquement le 2e element du tableau valr1
    290      call efpfle(fid,profil1,1,nomprofil1,ret)
    291      if (ret .ne. 0 ) then
    292         print *,'Erreur à la création du profil : ', nomprofil1
    293         ret = -1
    294      endif
    295
    296
    297  C     ** Ecriture du champ reel
    298  C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
    299  C     ** - Extrait a partir du profil de nom "profil1(1)"
    300  C     ** - Pas de temps = 5.6
    301  C     ** - Numero d ordre = 2
    302      dt = 5.6
    303      call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
    304       1               MED_NOGAUSS,MED_ALL,nomprofil1,USER_MODE,
    305       2               MED_MAILLE,MED_TRIA6,
    306       3               2,"ms",dt,2,ret)
    307      if (ret .ne. 0 ) then
    308         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
    309         ret = -1
    310      endif
    311
    312  C     ** Ecriture du champ reel
    313  C     ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
    314  C     ** - Extrait a partir du profil de nom "profil1(1)"
    315  C     ** - Pas de temps = 5.6
    316  C     ** - Numero d ordre = 2
    317      dt = 5.6
    318      call efchae(fid,maa2,nomcha1,valr1_2p,USER_INTERLACE,nval1_2,
    319       1               gauss1_2,MED_ALL,nomprofil1,USER_MODE,
    320       2               MED_MAILLE,MED_TRIA6,
    321       3               2,"ms",dt,2,ret)
    322      if (ret .ne. 0 ) then
    323         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
    324         ret = -1
    325      endif
    326
    327
    328  C     ** Ecriture du champ reel
    329  C     ** - 2e composante du 2e element du champ
    330  C     ** - Extrait a partir du profil de nom "profil1(1)"
    331  C     ** - Pas de temps = 5.7
    332  C     ** - Numero d ordre = 2
    333      dt = 5.7
    334      call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3,
    335       1               MED_NOGAUSS,2,nomprofil1,USER_MODE,
    336       2               MED_MAILLE,MED_TRIA6,
    337       3               3,"ms",dt,2,ret)
    338      if (ret .ne. 0 ) then
    339         print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
    340         ret = -1
    341      endif
    342
    343
    344  C     ** Ecriture du champ entier n°2
    345  C     ** - 1ere composante des éléments de valr2
    346  C     ** - pas de pas de temps, ni de numero d ordre
    347      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
    348       1     MED_NOGAUSS,1,MED_NOPFL,MED_NO_PFLMOD,MED_ARETE,
    349       1               MED_SEG2,MED_NOPDT,"",0.0,MED_NONOR,ret)
    350      if (ret .ne. 0 ) then
    351         print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
    352         ret = -1
    353      endif
    354
    355  C     ** Ecriture du champ entier n°2
    356  C     ** - 2ere composante des éléments de valr2
    357  C     ** - pas de pas de temps, ni de numero d ordre
    358  C     ** - pour des raisons de complétude des tests on change
    359  C     **   le type d élément (aucun sens phys.))
    360      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
    361       1     MED_NOGAUSS,2,MED_NOPFL,MED_NO_PFLMOD,MED_NOEUD,
    362       1               0,MED_NOPDT,"",0.0,MED_NONOR,ret)
    363      if (ret .ne. 0 ) then
    364        print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
    365        ret = -1
    366      endif
    367
    368
    369  C     ** Ecriture du champ entier n°2
    370  C     ** - 3ere composante des éléments de valr2
    371  C     ** - pas de pas de temps, ni de numero d'ordre
    372  C     ** - pour des raisons de complétude des tests on change
    373  C     **   le type d'élément (aucun sens phys.))
    374      call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2,
    375       1     MED_NOGAUSS,3,MED_NOPFL,MED_NO_PFLMOD,MED_FACE,
    376       1               MED_TRIA6,MED_NOPDT,"",0.0,MED_NONOR,ret)
    377      if (ret .ne. 0 ) then
    378         print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
    379         ret = -1
    380      endif
    381
    382  C     ** Creation de profil
    383  C     ** - selectionne les elements 1,3,5 du tableau valr2
    384      call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
    385      if (ret .ne. 0 ) then
    386         print *,'Erreur à l''écriture du profil : ', 'profil2(champ2)'
    387         ret = -1
    388      endif
    389
    390
    391  C     ** Ecriture du champ entier n°2
    392  C     ** - 3eme composante des éléments de valr2
    393  C     ** - pas de pas de temps, ni de numero d'ordre
    394  C     ** - profils
    395  C     ** - pour des raisons de complétude des tests on change
    396  C     **   le type d'élément (aucun sens phys.))
    397      call efchae(fid,maa1,nomcha2,valr2p,USER_INTERLACE,nval2,
    398       1     MED_NOGAUSS,3,"PROFIL(champ2)",USER_MODE,MED_MAILLE,
    399       1               MED_TRIA6,MED_NOPDT,"",0.0,MED_NONOR,ret)
    400      if (ret .ne. 0 ) then
    401         print *,'Erreur à l''écriture du profil : ', 'profil2(champ2)'
    402         ret = -1
    403      endif
    404
    405  C     ** Fermeture du fichier *
    406      call efferm (fid,ret)
    407      if (ret .ne. 0 ) then
    408         print *,'Erreur à la fermeture du fichier : '
    409         ret = -1
    410      endif
    411
    412      print *,"Le code retour : ",ret
    413      call efexit(ret)
    414
    415      end
    416
    417
    418