1C* This file is part of MED. 2C* 3C* COPYRIGHT (C) 1999 - 2019 EDF R&D, CEA/DEN 4C* MED is free software: you can redistribute it and/or modify 5C* it under the terms of the GNU Lesser General Public License as published by 6C* the Free Software Foundation, either version 3 of the License, or 7C* (at your option) any later version. 8C* 9C* MED is distributed in the hope that it will be useful, 10C* but WITHOUT ANY WARRANTY; without even the implied warranty of 11C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12C* GNU Lesser General Public License for more details. 13C* 14C* You should have received a copy of the GNU Lesser General Public License 15C* along with MED. If not, see <http://www.gnu.org/licenses/>. 16C* 17 18C ****************************************************************************** 19C * - Nom du fichier : test10.f 20C * 21C * - Description : ecriture de champs de resultats MED 22C * 23C ****************************************************************************** 24 program test10 25C 26 implicit none 27 include 'med.hf' 28C 29 integer*8 fid 30 integer ret,USER_INTERLACE,USER_MODE 31 real*8 a,b,p1,p2,dt 32 33 character*32 maa1,maa2,maa3 34 character*13 lien_maa2 35C CHAMP N°1 36 character*32 nomcha1 37 character*16 comp1(2), unit1(2) 38 character*16 dtunit1, nounit 39 integer ncomp1 40C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1 41 integer ngauss1_1 42 character*32 gauss1_1 43 real*8 refcoo1(12), gscoo1_1(12), wg1_1(6) 44 integer nval1_1 45 real*8 valr1_1(1*6*2) 46C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1 47 integer ngauss1_2 48 character*32 gauss1_2 49 real*8 gscoo1_2(6), wg1_2(3) 50 integer nval1_2 51 real*8 valr1_2(2*3*2) 52 real*8 valr1_2p(2*3) 53C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1 54 integer ngauss1_3,nval1_3 55 real*8 valr1_3(2*3*2) 56 real*8 valr1_3p(2*2) 57 58C CHAMP N°2 59 character*32 nomcha2 60 character*16 comp2(3), unit2(3) 61 integer ncomp2, nval2 62 integer valr2(5*3), valr2p(3*3) 63 64C PROFILS UTILISES 65 character*32 nomprofil1 66 integer profil1(2) , profil2(3) 67 68 parameter (USER_INTERLACE = MED_FULL_INTERLACE) 69 parameter (USER_MODE = MED_COMPACT ) 70 parameter ( a=0.446948490915965D0, b=0.091576213509771D0 ) 71 parameter ( p1=0.11169079483905D0, p2=0.0549758718227661D0 ) 72C MAILLAGES 73 parameter ( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" ) 74 parameter ( lien_maa2= "./testfoo.med" ) 75C CHAMP N°1 76 parameter ( nomcha1 = "champ reel" ) 77 parameter ( ncomp1 = 2 ) 78 parameter ( dtunit1 = " ") 79 parameter ( nounit = " ") 80C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1 81 parameter ( gauss1_1 = "Model n1" ) 82 parameter ( ngauss1_1 = 6 ) 83C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1 84 parameter ( gauss1_2 = "Model n2" ) 85 parameter ( ngauss1_2 = 3 ) 86C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1 87 parameter ( ngauss1_3 = 6 ) 88 parameter ( nval1_3 = 6 ) 89C CHAMP N°2 90 parameter ( nomcha2="champ entier") 91 parameter ( ncomp2 = 3, nval2= 5 ) 92C PROFILS 93 parameter ( nomprofil1 = "PROFIL(champ(1))" ) 94 95 96C CHAMP N°1 97 data comp1 /"comp1", "comp2"/ 98 data unit1 /"unit1","unit2"/ 99C 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/ 105C 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 / 109C 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 / 113C 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 / 118C 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 gscoo1_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.0D0/3 146 gscoo1_2(2) = 1.0D0/3 147 gscoo1_2(3) = -2.0D0/3 148 gscoo1_2(4) = -2.0D0/3 149 gscoo1_2(5) = 1.0D0/3 150 gscoo1_2(6) = -2.0D0/3 151 152 wg1_2(1) = 2.0D0/3 153 wg1_2(2) = 2.0D0/3 154 wg1_2(3) = 2.0D0/3 155 156C ** ouverture du fichier ** 157 call efouvr(fid,'test10.med',MED_LECTURE_ECRITURE, ret) 158 if (ret .ne. 0 ) then 159 print *,'Erreur à l''ouverture du fichier : ','test10.med' 160 call efexit(-1) 161 endif 162 163C ** 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 171C ** 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 180C ** 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 187C ** 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 194C ** 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 201C ** 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 209C ** 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 218C ** Ecriture du champ n°1 219C ** - enregistre uniquement la composante n°2 de valr1_1 220C ** - pas de pas de temps, ni de numero d'ordre 221 dt = 0.0D0 222 call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1, 223 1 gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD, 224 2 MED_MAILLE,MED_TRIA6, 225 3 MED_NOPDT,dtunit1,dt,MED_NONOR,ret) 226 if (ret .ne. 0 ) then 227 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1' 228 ret = -1 229 endif 230 231C ** Nouvelle Ecriture du champ reel en mode remplacement 232C ** - complete le champ precedent en enregistrant les composantes 1 233C ** - pas de pas de temps, ni de numero d'ordre 234 call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1, 235 1 gauss1_1,1,MED_NOPFL,MED_NO_PFLMOD, 236 2 MED_MAILLE,MED_TRIA6, 237 3 MED_NOPDT,dtunit1,dt,MED_NONOR,ret) 238 if (ret .ne. 0 ) then 239 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2' 240 ret = -1 241 endif 242 243C ** Ecriture sur le champ reel 244C ** - De la 1ere composante du tableau valr1_2 245C ** - Avec un pas de temps égal a 5.5 246C ** - Pas de numero d'ordre 247C ** - maa2 est distant 248 dt = 5.5D0 249 call efchae(fid,maa2,nomcha1,valr1_2,USER_INTERLACE,nval1_2, 250 1 gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD, 251 2 MED_MAILLE,MED_TRIA6, 252 3 1,"ms",dt,MED_NONOR,ret) 253 if (ret .ne. 0 ) then 254 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3' 255 ret = -1 256 endif 257 258C ** Ecriture sur le champ reel 259C ** - De la 2ere composante du tableau valr1_2 260C ** - Avec un pas de temps égal a 5.5 261C ** - Pas de numero d'ordre 262C ** - maa1 est local 263 dt = 5.5D0 264 call efchae(fid,maa1,nomcha1,valr1_1,USER_INTERLACE,nval1_1, 265 1 gauss1_1,2,MED_NOPFL,MED_NO_PFLMOD, 266 2 MED_MAILLE,MED_TRIA6, 267 3 1,"ms",dt,MED_NONOR,ret) 268 if (ret .ne. 0 ) then 269 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4' 270 ret = -1 271 endif 272 273 274C ** Ecriture sur le champ reel 275C ** - De la 1ere composante du tableau valr1_1 276C ** - Avec un pas de temps égal a 5.5 277C ** - Numero d'ordre egal a 2 278C ** - maa3 est local 279 dt = 5.5D0 280 call efchae(fid,maa3,nomcha1,valr1_2,USER_INTERLACE,nval1_2, 281 1 gauss1_2,1,MED_NOPFL,MED_NO_PFLMOD, 282 2 MED_MAILLE,MED_TRIA6, 283 3 1,"ms",dt,2,ret) 284 if (ret .ne. 0 ) then 285 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5' 286 ret = -1 287 endif 288 289C ** Creation de profil 290C ** - qui selectionne uniquement le 2e element du tableau valr1 291 call efpfle(fid,profil1,1,nomprofil1,ret) 292 if (ret .ne. 0 ) then 293 print *,'Erreur à la création du profil : ', nomprofil1 294 ret = -1 295 endif 296 297 298C ** Ecriture du champ reel 299C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL) 300C ** - Extrait a partir du profil de nom "profil1(1)" 301C ** - Pas de temps = 5.6 302C ** - Numero d'ordre = 2 303 dt = 5.6D0 304 call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3, 305 1 MED_NOGAUSS,MED_ALL,nomprofil1,USER_MODE, 306 2 MED_MAILLE,MED_TRIA6, 307 3 2,"ms",dt,2,ret) 308 if (ret .ne. 0 ) then 309 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6' 310 ret = -1 311 endif 312 313C ** Ecriture du champ reel 314C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL) 315C ** - Extrait a partir du profil de nom "profil1(1)" 316C ** - Pas de temps = 5.6 317C ** - Numero d'ordre = 2 318 dt = 5.6D0 319 call efchae(fid,maa2,nomcha1,valr1_2p,USER_INTERLACE,nval1_2, 320 1 gauss1_2,MED_ALL,nomprofil1,USER_MODE, 321 2 MED_MAILLE,MED_TRIA6, 322 3 2,"ms",dt,2,ret) 323 if (ret .ne. 0 ) then 324 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7' 325 ret = -1 326 endif 327 328 329C ** Ecriture du champ reel 330C ** - 2e composante du 2e element du champ 331C ** - Extrait a partir du profil de nom "profil1(1)" 332C ** - Pas de temps = 5.7 333C ** - Numero d'ordre = 2 334 dt = 5.7D0 335 call efchae(fid,maa1,nomcha1,valr1_3p,USER_INTERLACE,nval1_3, 336 1 MED_NOGAUSS,2,nomprofil1,USER_MODE, 337 2 MED_MAILLE,MED_TRIA6, 338 3 3,"ms",dt,2,ret) 339 if (ret .ne. 0 ) then 340 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8' 341 ret = -1 342 endif 343 344 345C ** Ecriture du champ entier n°2 346C ** - 1ere composante des éléments de valr2 347C ** - pas de pas de temps, ni de numero d'ordre 348 dt = 0.0D0 349 call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2, 350 1 MED_NOGAUSS,1,MED_NOPFL,MED_NO_PFLMOD,MED_ARETE, 351 1 MED_SEG2,MED_NOPDT,nounit,dt,MED_NONOR,ret) 352 if (ret .ne. 0 ) then 353 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1' 354 ret = -1 355 endif 356 357C ** Ecriture du champ entier n°2 358C ** - 2ere composante des éléments de valr2 359C ** - pas de pas de temps, ni de numero d'ordre 360C ** - pour des raisons de complétude des tests on change 361C ** le type d'élément (aucun sens phys.)) 362 call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2, 363 1 MED_NOGAUSS,2,MED_NOPFL,MED_NO_PFLMOD,MED_NOEUD, 364 1 0,MED_NOPDT,nounit,dt,MED_NONOR,ret) 365 if (ret .ne. 0 ) then 366 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2' 367 ret = -1 368 endif 369 370 371C ** Ecriture du champ entier n°2 372C ** - 3ere composante des éléments de valr2 373C ** - pas de pas de temps, ni de numero d'ordre 374C ** - pour des raisons de complétude des tests on change 375C ** le type d'élément (aucun sens phys.)) 376 call efchae(fid,maa1,nomcha2,valr2,USER_INTERLACE,nval2, 377 1 MED_NOGAUSS,3,MED_NOPFL,MED_NO_PFLMOD,MED_FACE, 378 1 MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret) 379 if (ret .ne. 0 ) then 380 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3' 381 ret = -1 382 endif 383 384C ** Creation de profil 385C ** - selectionne les elements 1,3,5 du tableau valr2 386 call efpfle(fid,profil2,3,"PROFIL(champ2)",ret) 387 if (ret .ne. 0 ) then 388 print *,'Erreur à l''écriture du profil : ', 389 1 'profil2(champ2)' 390 ret = -1 391 endif 392 393 394C ** Ecriture du champ entier n°2 395C ** - 3eme composante des éléments de valr2 396C ** - pas de pas de temps, ni de numero d'ordre 397C ** - profils 398C ** - pour des raisons de complétude des tests on change 399C ** le type d'élément (aucun sens phys.)) 400 call efchae(fid,maa1,nomcha2,valr2p,USER_INTERLACE,nval2, 401 1 MED_NOGAUSS,3,"PROFIL(champ2)",USER_MODE,MED_MAILLE, 402 1 MED_TRIA6,MED_NOPDT,nounit,dt,MED_NONOR,ret) 403 if (ret .ne. 0 ) then 404 print *,'Erreur à l''écriture du profil : ', 405 1 'profil2(champ2)' 406 ret = -1 407 endif 408 409C ** Fermeture du fichier * 410 call efferm (fid,ret) 411 if (ret .ne. 0 ) then 412 print *,'Erreur à la fermeture du fichier : ' 413 ret = -1 414 endif 415 416 print *,"Le code retour : ",ret 417 call efexit(ret) 418 419 end 420 421 422 423