conv_med.F

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\conv_med.F
00002 !
00063       MODULE CONV_MED
00064       CONTAINS
00065 !                       *****************
00066                         SUBROUTINE READ_MED
00067 !                       *****************
00068      &(MEDFILE,LIMFILE)
00069 !
00070 !***********************************************************************
00071 ! STBTEL   V6P1                                   11/07/2011
00072 !***********************************************************************
00073 !
00074 !BRIEF    READS A FILE OF MED FORMAT AND FILL THE MESH OBJECT
00075 !
00076 !HISTORY  Y.AUDOUIN (EDF)
00077 !+        11/07/2011
00078 !+        V6P1
00079 !+   CREATION OF THE FILE
00080 !
00081 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00082 !| MEDFILE        |-->| NAME OF THE MED FILE IN THE TEMPORARY FOLDER
00083 !| LIMFILE        |-->| NAME OF THE BOUNDARY FILE IN THE TEMPORARY FOLDER
00084 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00085 !
00086       USE DECLARATIONS_STBTEL
00087       USE CONV_LIM
00088 !
00089       IMPLICIT NONE
00090       ! LANGAE AND OUTPUT VALUE
00091       INTEGER LNG,LU
00092       COMMON/INFO/LNG,LU
00093 !
00094 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00095 !
00096       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: MEDFILE
00097       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: LIMFILE
00098 
00099 !
00100 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00101 !
00102 #if defined(HAVE_MED)
00103       INTEGER :: IERR,ITIME,IVAR
00104       INTEGER :: NMAA,MTYPE
00105       INTEGER :: PROFIL(1)
00106       INTEGER :: I,J,K,IPTFR
00107       INTEGER :: TYPENT,TYPGEO,TYPE1,TYPREP
00108       INTEGER :: NGAUSS,NUMDT,NUMO,NVAL,NCOMP
00109       DOUBLE PRECISION, ALLOCATABLE :: COOR(:)
00110       DOUBLE PRECISION :: TIME, DDUM
00111       LOGICAL :: LOCAL
00112       CHARACTER(LEN=SNAME_SIZE) :: DTUNIT
00113       CHARACTER(LEN=SNAME_SIZE), ALLOCATABLE :: NAMEVAR2(:), UNITVAR2(:)
00114       CHARACTER(LEN=NAME_SIZE) :: FIELDNAME
00115       INTEGER, ALLOCATABLE :: NUFANO(:)
00116       INTEGER :: IDUM, NVAR_MED
00117       CHARACTER :: CDUM
00118       CHARACTER(LEN=NAME_SIZE) :: MESHNAME,MESHNAME2
00119       LOGICAL :: FIRST,LDUM
00120       DOUBLE PRECISION, ALLOCATABLE :: VAL(:)
00121       INTEGER, ALLOCATABLE :: CON(:)
00122       CHARACTER(LEN=COMMENT_SIZE) :: ATTDESCR
00123       INTEGER :: NUM
00124       INTEGER :: TYPGEO2
00125       DOUBLE PRECISION, ALLOCATABLE :: RES(:)
00126       CHARACTER(LEN=SNAME_SIZE), ALLOCATABLE :: ELEMNAME(:)
00127       INTEGER, ALLOCATABLE :: ELEMNUM(:)
00128       INTEGER, ALLOCATABLE :: ELEMNUM2(:)
00129       LOGICAL :: MYFALSE
00130       INTEGER :: POS
00131 !
00132       WRITE(LU,*) '----------------------------------------------------'
00133       IF(LNG.EQ.1) WRITE(LU,*) '------BEGINNING READING OF MED FILE'
00134       IF(LNG.EQ.2) WRITE(LU,*) '------DEBUT LECTURE DU FICHIER MED'
00135       WRITE(LU,*) '----------------------------------------------------'
00136 !
00137 !-----------------------------------------------------------------------
00138 !
00139       CALL MFIOPE(NINP, MEDFILE, MED_ACC_RDONLY, IERR)
00140       CALL FNCT_CHECK(IERR,'MFIOPE')
00141 !
00142       ! READING THE NUMBER OF MESH IN THE FILE
00143       CALL MMHNMH(NINP,NMAA,IERR)
00144       CALL FNCT_CHECK(IERR,'MMHNMH')
00145       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATIONS SUR LE MAILLAGE'
00146       IF(LNG.EQ.2) WRITE(LU,*) '---MESH INFORMATIONS'
00147       ! THERE IS SUPPOSED TO BE ONLY ONE MESH
00148       IF (NMAA .EQ. 1) THEN
00149         ! RADING THE NUMBER OF AXIS
00150         CALL MMHNAX(NINP,1,MESH2%NDIM,IERR)
00151         CALL FNCT_CHECK(IERR,"MMHNAX")
00152         ALLOCATE(MESH2%NAMECOO(MESH2%NDIM),STAT=IERR)
00153         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NAMECOO')
00154         ALLOCATE(MESH2%UNITCOO(MESH2%NDIM),STAT=IERR)
00155         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%UNITCOO')
00156         ! READING MESH INFORMATIONS
00157         CALL MMHMII(NINP,1,MESHNAME,MESH2%NDIM,IDUM,MTYPE,
00158      &              MESH2%DESCRIPTION,DTUNIT,IDUM,IDUM,
00159      &              IDUM,MESH2%NAMECOO,MESH2%UNITCOO,IERR)
00160         CALL FNCT_CHECK(IERR,'MMHMII')
00161         IF(MESHNAME.EQ.'MESH') THEN
00162           MESH2%TITLE = MESH2%DESCRIPTION(1:72)
00163           MESH2%DESCRIPTION = 'NO DESCRIPTION'
00164         ELSE
00165           MESH2%TITLE = MESHNAME
00166         ENDIF
00167         IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00168      &          'NOM DU MAILLAGE : ',MESH2%TITLE
00169         IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'MESH NAME: ',MESH2%TITLE
00170         IF(DEBUG) WRITE(LU,*) 'NDIM :',MESH2%NDIM
00171         IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOM DE COO: ',
00172      &                          MESH2%NAMECOO
00173         IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'UNITE DE COO: ',
00174      &                          MESH2%UNITCOO
00175         IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NAME OF COO: ',
00176      &                                        MESH2%NAMECOO
00177         IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'UNIT OF COO: ',
00178      &                          MESH2%UNITCOO
00179       ELSE
00180         IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : NOMBRE DE MAILLAGE ',
00181      &                           'DIFFERENT DE 1'
00182         IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: NUMBER OF MESH DIFFERENT TO 1'
00183         CALL PLANTE(1)
00184       END IF
00185       ! READING THE NUMBER OF ELEMENTS
00186       ! WE HAVE TO TEST FOR EACH TYPE THE NUMBER OF ELEMENTS
00187       IF(MESH2%NDIM.EQ.2) THEN
00188         ! IF IN 2D WE HAVE TRIANGLE OR QUADRA
00189         TYPGEO = MED_TRIA3
00190         MESH2%NDP = 3
00191         MESH2%TYPE_ELEM = TYPE_TRIA3
00192         CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO,
00193      &              MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,NUM,IERR)
00194         CALL FNCT_CHECK(IERR,'MMHNME')
00195         IF(NUM.EQ.0) THEN
00196           TYPGEO = MED_QUAD4
00197           MESH2%NDP = 4
00198           MESH2%TYPE_ELEM = TYPE_QUAD4
00199           CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO,
00200      &                MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,NUM,IERR)
00201           CALL FNCT_CHECK(IERR,'MMHNME')
00202           IF(NUM.EQ.0) THEN
00203             IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : TYPE D ELEMENTS INCONNU'
00204             IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: UNKNOWN TYPE OF ELEMENTS'
00205             CALL PLANTE(1)
00206           ENDIF
00207           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00208      &                       'ELEMENT DE TYPE : MED_QUAD4'
00209           IF(DEBUG.AND.(LNG.EQ.2))WRITE(LU,*) 'ELEMENT TYPE: MED_QUAD4'
00210         ELSE
00211           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00212      &                       'ELEMENT DE TYPE : MED_TRIA3'
00213           IF(DEBUG.AND.(LNG.EQ.2))WRITE(LU,*) 'ELEMENT TYPE: MED_TRIA3'
00214         ENDIF
00215         MESH2%NELEM = NUM
00216       ELSE
00217         ! IF IN 3D WE HAVE TETRA OR PRISM AND MAYBE A 2D ELEMENT (ESTEL)
00218         TYPGEO = MED_PENTA6
00219         MESH2%NDP = 6
00220         MESH2%TYPE_ELEM = TYPE_PRISM6
00221         CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO,
00222      &              MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,NUM,IERR)
00223         CALL FNCT_CHECK(IERR,'MMHNME')
00224         IF(NUM.EQ.0) THEN
00225           TYPGEO = MED_TETRA4
00226           MESH2%NDP = 4
00227           MESH2%TYPE_ELEM = TYPE_TETRA4
00228           CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO,
00229      &                MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,NUM,IERR)
00230           CALL FNCT_CHECK(IERR,'MMHNME')
00231           IF(NUM.EQ.0) THEN
00232             IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : TYPE D ELEMENTS INCONNU'
00233             IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: UNKNOWN TYPE OF ELEMENTS'
00234             CALL PLANTE(1)
00235           ENDIF
00236           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00237      &                       'ELEMENT DE TYPE : MED_TETRA4'
00238           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00239      &                       'ELEMENT TYPE: MED_TETRA4'
00240         ELSE
00241           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00242      &                       'ELEMENT DE TYPE : MED_PENTA6'
00243           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00244      &                       'ELEMENT TYPE: MED_PENTA6'
00245         ENDIF
00246         MESH2%NELEM = NUM
00247         ! LOOKING IF THERE IS A 2D ELEMENT TYPE (ESTEL)
00248         TYPGEO2 = MED_TRIA3
00249         MESH2%NDP2 = 3
00250         MESH2%TYPE_ELEM2 = TYPE_TRIA3
00251         CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO2,
00252      &              MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,NUM,IERR)
00253         CALL FNCT_CHECK(IERR,'MMHNME')
00254         IF(NUM.EQ.0) THEN
00255           TYPGEO2 = MED_QUAD4
00256           MESH2%NDP2 = 4
00257           MESH2%TYPE_ELEM2 = TYPE_QUAD4
00258           CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,
00259      &                TYPGEO2,MED_CONNECTIVITY,MED_NODAL,IDUM,IDUM,
00260      &                NUM,IERR)
00261           CALL FNCT_CHECK(IERR,'MMHNME')
00262           IF(NUM.NE.0) THEN
00263           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00264      &                       'ELEMENT DE TYPE 2 : MED_QUAD4'
00265           IF(DEBUG.AND.(LNG.EQ.2))WRITE(LU,*)
00266      &                       'ELEMENT TYPE 2: MED_QUAD4'
00267           ENDIF
00268         ELSE
00269           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00270      &                       'ELEMENT DE TYPE 2 : MED_TRIA3'
00271           IF(DEBUG.AND.(LNG.EQ.2))WRITE(LU,*)'ELEMENT TYPE 2: MED_TRIA3'
00272         ENDIF
00273         MESH2%NELEM2 = NUM
00274       ENDIF
00275       IF(DEBUG) WRITE(LU,*) 'NELEM :',MESH2%NELEM
00276       IF(MESH2%NELEM2.NE.0.AND.DEBUG) WRITE(LU,*)'NELEM2 :',MESH2%NELEM2
00277       ! READING THE NUMBER OF NODES
00278       CALL MMHNME(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,MED_NONE,
00279      &            MED_COORDINATE,MED_NODAL,IDUM,IDUM,MESH2%NPOIN,IERR)
00280       CALL FNCT_CHECK(IERR,'MMHNME')
00281       IF(DEBUG) WRITE(LU,*) 'NPOIN :',MESH2%NPOIN
00282 !
00283       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATION SUR LES FAMILLES'
00284       IF(LNG.EQ.2) WRITE(LU,*) '---FAMILY INFORMATION'
00285       CALL MFANFA(NINP,MESHNAME,MESH2%NFAM,IERR)
00286       CALL FNCT_CHECK(IERR,'MFANFA')
00287       IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOMBRE DE FAMILLES :',
00288      &                        MESH2%NFAM
00289       IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NUMBER OF FAMILIES:',
00290      &                        MESH2%NFAM
00291       IF(MESH2%NFAM .EQ. 0) THEN
00292         IF(LNG.EQ.1) WRITE(LU,*) 'PAS DE FAMILLES'
00293         IF(LNG.EQ.2) WRITE(LU,*) 'NO FAMILIES'
00294       ELSE
00295         ! READING FAMILIES INFORMATIONS
00296         ALLOCATE(MESH2%IDFAM(MESH2%NFAM),STAT=IERR)
00297         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IDFAM')
00298         ALLOCATE(MESH2%NAMEFAM(MESH2%NFAM),STAT=IERR)
00299         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NAMEFAM')
00300         ALLOCATE(MESH2%VALFAM(MESH2%NFAM),STAT=IERR)
00301         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%VALFAM')
00302         ALLOCATE(MESH2%NGROUPFAM(MESH2%NFAM),STAT=IERR)
00303         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NGROUPFAM')
00304         ALLOCATE(MESH2%GROUPFAM(MESH2%NFAM,10),STAT=IERR)
00305         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%GROUPFAM')
00306         MESH2%GROUPFAM(:,:) = ' '
00307         MESH2%NGROUPFAM = 0
00308         DO I=1,MESH2%NFAM
00309           CALL MFANFG(NINP,MESHNAME,I,MESH2%NGROUPFAM(I),IERR)
00310           CALL FNCT_CHECK(IERR,'MFANFG')
00311           IF(MESH2%NGROUPFAM(I).EQ.0) THEN
00312             CALL MFAFAI(NINP,MESHNAME,I,MESH2%NAMEFAM(I),MESH2%IDFAM(I),
00313      &                  MESH2%GROUPFAM(I,1),IERR)
00314           ELSE
00315             CALL MFAFAI(NINP,MESHNAME,I,MESH2%NAMEFAM(I),MESH2%IDFAM(I),
00316      &                  MESH2%GROUPFAM(I,1:MESH2%NGROUPFAM(I)),IERR)
00317           ENDIF
00318           CALL FNCT_CHECK(IERR,'MFAFAI')
00319           ! IDENTIFYING COLOR VALUE FROM NAME
00320           POS = INDEX(MESH2%NAMEFAM(I),':')
00321           IF (POS.EQ.0) THEN
00322             MESH2%VALFAM(I) = 0
00323           ELSE
00324             IF (MESH2%NAMEFAM(I)(POS-2:POS-2).EQ.'_') THEN
00325               READ(MESH2%NAMEFAM(I)(POS-1:POS-1),'(I1)') MESH2%VALFAM(I)
00326             ELSE IF(MESH2%NAMEFAM(I)(POS-3:POS-3).EQ.'_') THEN
00327               READ(MESH2%NAMEFAM(I)(POS-2:POS-1),'(I2)') MESH2%VALFAM(I)
00328             ELSE IF(MESH2%NAMEFAM(I)(POS-4:POS-4).EQ.'_') THEN
00329               READ(MESH2%NAMEFAM(I)(POS-3:POS-1),'(I3)') MESH2%VALFAM(I)
00330             ELSE
00331               WRITE(LU,*) 'INCORRECT NUMBER OF COLOR'
00332             ENDIF
00333           ENDIF
00334           IF(DEBUG) WRITE(LU,*) 'NAMEFAM : ',MESH2%NAMEFAM(I)
00335           IF(DEBUG) WRITE(LU,*) 'VALFAM : ',MESH2%VALFAM(I)
00336           IF(DEBUG) WRITE(LU,*) 'IDFAM : ',MESH2%IDFAM(I)
00337           IF(DEBUG) WRITE(LU,*) 'NGROUP : ',MESH2%NGROUPFAM(I)
00338           IF(MESH2%NGROUPFAM(I).NE.0) THEN
00339             DO J=1,MESH2%NGROUPFAM(I)
00340               IF(DEBUG) WRITE(LU,*) 'GROUP : ',TRIM(MESH2%GROUPFAM(I,J))
00341             ENDDO
00342           ENDIF
00343         ENDDO
00344       ENDIF
00345 !
00346       ! READING THE COORDINATES
00347       ALLOCATE(MESH2%X(MESH2%NPOIN),STAT=IERR)
00348       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%X')
00349       ALLOCATE(MESH2%Y(MESH2%NPOIN),STAT=IERR)
00350       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%Y')
00351       IF(MESH2%NDIM.EQ.3) THEN
00352         ALLOCATE(MESH2%Z(MESH2%NPOIN),STAT=IERR)
00353         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%Z')
00354       ENDIF
00355       ! REDING THE COORDINATES
00356       ALLOCATE(COOR(MESH2%NPOIN*MESH2%NDIM),STAT=IERR)
00357       CALL FNCT_CHECK(IERR,'ALLOCATE COOR')
00358       CALL MMHCOR(NINP,TRIM(MESHNAME),MED_NO_DT,MED_NO_IT,
00359      &            MED_NO_INTERLACE,COOR,IERR)
00360       CALL FNCT_CHECK(IERR,'MMHCOR')
00361       DO I=1,MESH2%NPOIN
00362         MESH2%X(I) = COOR(I+0*MESH2%NPOIN)
00363         MESH2%Y(I) = COOR(I+1*MESH2%NPOIN)
00364         IF(MESH2%NDIM.EQ.3) THEN
00365           MESH2%Z(I) = COOR(I+2*MESH2%NPOIN)
00366         ENDIF
00367       ENDDO
00368       DEALLOCATE(COOR)
00369 !
00370       ! READING IKLE
00371       ALLOCATE(MESH2%IKLES(MESH2%NELEM*MESH2%NDP),STAT=IERR)
00372       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES')
00373       ALLOCATE(CON(MESH2%NELEM*MESH2%NDP),STAT=IERR)
00374       CALL FNCT_CHECK(IERR,'ALLOCATE CON')
00375       ALLOCATE(ELEMNAME(MESH2%NELEM),STAT=IERR)
00376       CALL FNCT_CHECK(IERR,'ALLOCATE ELEMNAME')
00377       ALLOCATE(ELEMNUM(MESH2%NELEM),STAT=IERR)
00378       CALL FNCT_CHECK(IERR,'ALLOCATE ELEMNUM')
00379       MYFALSE = .FALSE.
00380       CALL MMHELR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,
00381      &            TYPGEO,MED_NODAL,MED_NO_INTERLACE,CON,MYFALSE,
00382      &            ELEMNAME,MYFALSE,ELEMNUM,MYFALSE,ELEMNUM,IERR)
00383       CALL FNCT_CHECK(IERR,'MMHELR')
00384       DEALLOCATE(ELEMNAME,ELEMNUM)
00385       ! CONVERTING IKLE INTO IKLES
00386       DO I=1,MESH2%NELEM
00387         DO J=1,MESH2%NDP
00388           MESH2%IKLES((I-1)*MESH2%NDP+J) = CON(I+(J-1)*MESH2%NELEM)
00389         ENDDO
00390       ENDDO
00391       DEALLOCATE(CON)
00392       ! READING IKLES2 IF NECESSARY
00393       IF(MESH2%NELEM2.NE.0) THEN
00394         ! READING IKLE2
00395         ALLOCATE(MESH2%IKLES2(MESH2%NELEM2*MESH2%NDP2),STAT=IERR)
00396         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES2')
00397         ALLOCATE(CON(MESH2%NELEM2*MESH2%NDP2),STAT=IERR)
00398         CALL FNCT_CHECK(IERR,'ALLOCATE CON BIS')
00399         ALLOCATE(ELEMNAME(MESH2%NELEM2),STAT=IERR)
00400         CALL FNCT_CHECK(IERR,'ALLOCATE ELEMNAME')
00401         ALLOCATE(ELEMNUM(MESH2%NELEM2),STAT=IERR)
00402         CALL FNCT_CHECK(IERR,'ALLOCATE ELEMNUM')
00403         CALL MMHELR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,
00404      &              TYPGEO2,MED_NODAL,MED_NO_INTERLACE,CON,MYFALSE,
00405      &              ELEMNAME,MYFALSE,ELEMNUM,MYFALSE,ELEMNUM,IERR)
00406         CALL FNCT_CHECK(IERR,'MMHELR TYPE2')
00407         ! CONVERTING IKLE2 INTO IKLES2
00408         DO I=1,MESH2%NELEM2
00409           DO J=1,MESH2%NDP2
00410             MESH2%IKLES2((I-1)*MESH2%NDP2+J) = CON(I+(J-1)*MESH2%NELEM2)
00411           ENDDO
00412         ENDDO
00413         DEALLOCATE(CON)
00414       ENDIF
00415 !
00416       ! READING GLOBAL NUMBERING IF AVAILABLE
00417       ALLOCATE(MESH2%KNOLG(MESH2%NPOIN),STAT=IERR)
00418       CALL FNCT_CHECK(IERR,"ALLOCATE MESH2%KNOLG")
00419       MESH2%KNOLG = 0
00420       CALL MMHGNR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,
00421      &            MED_NONE,MESH2%KNOLG,IERR)
00422       ! CHECK IF THE NUMBERING IS AVAILABLE
00423       IF(IERR.NE.0) DEALLOCATE(MESH2%KNOLG)
00424 !
00425       IF(LNG.EQ.1) WRITE(LU,*)
00426      &            '---INFORMATIONS SUR LES CONDITIONS LIMITES'
00427       IF(LNG.EQ.2) WRITE(LU,*) '---BOUNDARY INFORMATIONS'
00428       ! READING EACH POINTS FAMILY
00429       ALLOCATE(MESH2%COLOR(MESH2%NPOIN),STAT=IERR)
00430       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%COLOR')
00431       MESH2%COLOR = 0
00432       CALL MMHFNR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,MED_NONE,
00433      &            MESH2%COLOR,IERR)
00434       ! DO NOT CHECK FOR IERR BECAUSE IF THEY ARE NO COLOR THE FUNCTION
00435       ! FAILS
00436       ! COMPUTE NPTFR
00437       MESH2%NPTFR = COUNT(MESH2%COLOR.NE.0)
00438       IF(MESH2%NPTFR.EQ.0) THEN
00439         ! CREATING IPOBO
00440         ALLOCATE(MESH2%IPOBO(MESH2%NPOIN),STAT=IERR)
00441         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IPOBO')
00442         MESH2%IPOBO=0
00443         IF(LIMFILE(1:1).EQ.' ') THEN
00444           IF(LNG.EQ.1) WRITE(LU,*) 'LE FICHIER MED NE CONTIENT PAS DE ',
00445      &                        'CONDITIONS LIMITES'
00446           IF(LNG.EQ.2) WRITE(LU,*) 'THE MED FILE CONTAINS NO BOUNDARY'
00447         ELSE
00448           CALL READ_LIM(LIMFILE)
00449           IF(DEBUG) WRITE(LU,*) 'NPTFR :',MESH2%NPTFR
00450           ! FILLING IPOBO
00451           DO I=1,MESH2%NPTFR
00452             MESH2%IPOBO(MESH2%NBOR(I)) = MESH2%LIHBOR(I)
00453           ENDDO
00454         ENDIF
00455       ELSE
00456         ! FILLING NBOR AND LIHBOR AN IPOBO
00457         ALLOCATE(MESH2%IPOBO(MESH2%NPOIN),STAT=IERR)
00458         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IPOBO')
00459         ALLOCATE(MESH2%NBOR(MESH2%NPTFR),STAT=IERR)
00460         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NBOR')
00461         ALLOCATE(MESH2%LIHBOR(MESH2%NPTFR),STAT=IERR)
00462         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%LIHBOR')
00463         IPTFR=1
00464         DO I=1,MESH2%NPOIN
00465           IF(MESH2%COLOR(I).NE.0) THEN
00466             MESH2%NBOR(IPTFR) = I
00467             J = 1
00468             DO WHILE(J.LE.MESH2%NFAM)
00469               IF(MESH2%COLOR(I).EQ.MESH2%IDFAM(J)) THEN
00470                 MESH2%COLOR(I) = MESH2%VALFAM(J)
00471                 MESH2%LIHBOR(IPTFR) = MESH2%VALFAM(J)
00472                 J = MESH2%NFAM
00473               ENDIF
00474               J = J + 1
00475             ENDDO
00476             MESH2%IPOBO(I) = 1
00477             IPTFR = IPTFR + 1
00478           ELSE
00479             MESH2%IPOBO(I) = 0
00480           ENDIF
00481         ENDDO
00482       ENDIF
00483       IF(DEBUG.AND.(LNG.EQ.1))
00484      &    WRITE(LU,*) 'NOMBRE DE POINT DE BORD :',MESH2%NPTFR
00485       IF(DEBUG.AND.(LNG.EQ.2))
00486      &    WRITE(LU,*) 'NUMBER OF BOUNDARY POINTS:',MESH2%NPTFR
00487       ALLOCATE(MESH2%NCOLOR(MESH2%NELEM),STAT=IERR)
00488       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR')
00489       MESH2%NCOLOR = 0
00490       CALL MMHFNR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO,
00491      &            MESH2%NCOLOR,IERR)
00492       ! DO NOT CHECK FUCNTION IERR BECAUSE IF THEY ARE NO COLOR THE
00493       ! FUNCTION RETURNS -1
00494       IF(COUNT(MESH2%NCOLOR.EQ.0) .EQ. MESH2%NELEM) THEN
00495         DEALLOCATE(MESH2%NCOLOR)
00496       ELSE
00497         DO J=1,MESH2%NELEM
00498           I = 1
00499           DO WHILE(I.LE.MESH2%NFAM)
00500             IF(MESH2%NCOLOR(J).EQ.MESH2%IDFAM(I)) THEN
00501               MESH2%NCOLOR(J) = MESH2%VALFAM(I)
00502               I = MESH2%NFAM
00503             ENDIF
00504             I = I + 1
00505           ENDDO
00506         ENDDO
00507       ENDIF
00508       ! READING FAMILIES FOR THE SECOND ELEMENT
00509       IF(MESH2%NELEM2.NE.0) THEN
00510         ALLOCATE(MESH2%NCOLOR2(MESH2%NELEM2),STAT=IERR)
00511         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR2')
00512         MESH2%NCOLOR2=0
00513         CALL MMHFNR(NINP,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,TYPGEO2,
00514      &              MESH2%NCOLOR2,IERR)
00515         ! DO NOT CHECK FUCNTION IERR BECAUSE IF THEY ARE NO COLOR THE
00516         ! FUNCTION RETURNS -1
00517         ! IF THE TABLE IS EMPTY WE DEALLOCATE IT
00518         IF(COUNT(MESH2%NCOLOR2.EQ.0) .EQ. MESH2%NELEM2) THEN
00519           DEALLOCATE(MESH2%NCOLOR2)
00520         ELSE
00521           DO J=1,MESH2%NELEM2
00522             I = 1
00523             DO WHILE(I.LE.MESH2%NFAM)
00524               IF(MESH2%NCOLOR2(J).EQ.MESH2%IDFAM(I)) THEN
00525                 MESH2%NCOLOR2(J) = MESH2%VALFAM(I)
00526                 I = MESH2%NFAM
00527               ENDIF
00528               I = I + 1
00529             ENDDO
00530           ENDDO
00531         ENDIF
00532       ENDIF
00533 !
00534       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATIONS SUR LES RESULTATS'
00535       IF(LNG.EQ.2) WRITE(LU,*) '---RESULTS INFORMATIONS'
00536       ! READING THE VARIABLES
00537       ! WE NEED TO CREATE A VARIABLE FOR EACH COMPONENENT
00538       ! SO WE HAVE TO COUNT THE NUMBER OF COMPONENT FOR EACH FIELD
00539       CALL MFDNFD(NINP,NVAR_MED,IERR)
00540       CALL FNCT_CHECK(IERR,'MFDNFD')
00541       IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOMBRE DE VARIABLE MED :',
00542      &            NVAR_MED
00543       IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NUMBER OF MED VARAIBLE:',
00544      &            NVAR_MED
00545       MESH2%NVAR = 0
00546       DO I=1,NVAR_MED
00547         CALL MFDNFC(NINP,I,NCOMP,IERR)
00548         CALL FNCT_CHECK(IERR,'MFDNFC')
00549         ALLOCATE(NAMEVAR2(NCOMP),STAT=IERR)
00550         CALL FNCT_CHECK(IERR,'ALLOCATE NAMEVAR2')
00551         ALLOCATE(UNITVAR2(NCOMP),STAT=IERR)
00552         CALL FNCT_CHECK(IERR,'ALLOCATE UNITVAR2')
00553         DTUNIT = ""
00554         CALL MFDFDI(NINP,I,FIELDNAME,MESHNAME2,IDUM,IDUM,NAMEVAR2,
00555      &              UNITVAR2,DTUNIT,IDUM,IERR)
00556         CALL FNCT_CHECK(IERR,'MFDFDI')
00557         ! REMOVE THE MODIF FIELD FROM THE COUNT OR
00558         ! IT WOULD DOUBLE THE NUMBER OF VARIABLES
00559         DEALLOCATE(NAMEVAR2,UNITVAR2)
00560         IF (FIELDNAME(1:11).EQ.'MODIF_FIELD') CYCLE
00561         MESH2%NVAR = MESH2%NVAR + NCOMP
00562       ENDDO
00563       IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOMBRE DE VARIABLES :',
00564      &                  MESH2%NVAR
00565       IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NUMBER OF VARIABLES:',
00566      &                  MESH2%NVAR
00567       IF(MESH2%NVAR.EQ.0) THEN
00568         IF(LNG.EQ.1) WRITE(LU,*)
00569      &            'LE FICHIER NE CONTIENT PAS DE RESULTATS'
00570         IF(LNG.EQ.2) WRITE(LU,*) 'THE FILE CONTAINS NO RESULTS'
00571       ELSE
00572         ALLOCATE(MESH2%NAMEVAR(MESH2%NVAR),STAT=IERR)
00573         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NAMEVAR')
00574         ALLOCATE(MESH2%UNITVAR(MESH2%NVAR),STAT=IERR)
00575         CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%UNITVAR')
00576 !
00577         FIRST = .TRUE.
00578         IVAR=1
00579         DO I=1,NVAR_MED
00580           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) '--DEBUT POUR VAR',I
00581           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) '--BEGINNING FOR VAR',I
00582           !GETTING INFORMATION ON THE FIELD
00583           CALL MFDNFC(NINP,I,NCOMP,IERR)
00584           CALL FNCT_CHECK(IERR,'MFDNFC')
00585           IF(DEBUG) WRITE(LU,*) 'NCOMP :',NCOMP
00586           ALLOCATE(NAMEVAR2(NCOMP),STAT=IERR)
00587           CALL FNCT_CHECK(IERR,'ALLOCATE NAMEVAR2 BIS')
00588           ALLOCATE(UNITVAR2(NCOMP),STAT=IERR)
00589           CALL FNCT_CHECK(IERR,'ALLOCATE UNITVAR2 BIS')
00590           CALL MFDFDI(NINP,I,FIELDNAME,MESHNAME,IDUM,IDUM,NAMEVAR2,
00591      &                UNITVAR2,DTUNIT,MESH2%TIMESTEP,IERR)
00592           CALL FNCT_CHECK(IERR,'MFDFDI')
00593           ! WE DON'T SAVE THE MODIF FIELD
00594           IF (FIELDNAME(1:11).EQ.'MODIF_FIELD')
00595      &      DEALLOCATE(NAMEVAR2,UNITVAR2)
00596           IF (FIELDNAME(1:11).EQ.'MODIF_FIELD') CYCLE
00597           DO J=1,NCOMP
00598             MESH2%NAMEVAR(IVAR+J-1) = FIELDNAME(1:16)
00599             IF(NCOMP.NE.1) CALL RENAME_VECTOR(MESH2%NAMEVAR(IVAR+J-1),J)
00600             MESH2%UNITVAR(IVAR+J-1) = UNITVAR2(J)
00601             IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00602      &               'NOM DE LA VARIABLE : ',MESH2%NAMEVAR(IVAR+J-1)
00603             IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00604      &               'UNITE DE LA VARIABLE : ',MESH2%UNITVAR(IVAR+J-1)
00605             IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00606      &               'NAME OF THE VARIABLE: ',MESH2%NAMEVAR(IVAR+J-1)
00607             IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00608      &               'UNIT OF THE VARIABLE: ',MESH2%UNITVAR(IVAR+J-1)
00609           ENDDO
00610           DEALLOCATE(NAMEVAR2,UNITVAR2)
00611           TYPENT = MED_NODE
00612           TYPGEO = MED_NONE
00613           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00614      &                  'NOMBRE DE PAS DE TEMPS :',MESH2%TIMESTEP
00615           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00616      &                  'NUMBER OF TIME STEPS:',MESH2%TIMESTEP
00617           ! DOING ALLOCATION ONLY ONCE
00618           IF(FIRST) THEN
00619             ALLOCATE(MESH2%RESULTS(MESH2%TIMESTEP,MESH2%NVAR,
00620      &               MESH2%NPOIN),STAT=IERR)
00621             CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%RESULTS')
00622             ALLOCATE(MESH2%TIMES(MESH2%TIMESTEP),STAT=IERR)
00623             CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%TIMES')
00624             MESH2%RESULTS = 0.D0
00625             MESH2%TIMES = 0.D0
00626             FIRST = .FALSE.
00627           ENDIF
00628           ! FOR EACH TIME STEP WE READ THE VARIABLE VALUES
00629           DO ITIME=1,MESH2%TIMESTEP
00630             IF(DEBUG) WRITE(LU,*) '-BEGINNING FOR TIMESTEP',ITIME
00631             !GET INFORMATION ON THE TIMESTEP
00632             CALL MFDCSI(NINP,FIELDNAME,ITIME,IDUM,IDUM,
00633      &                  MESH2%TIMES(ITIME),IERR)
00634             CALL FNCT_CHECK(IERR,'MFDCSI')
00635             IF(DEBUG.AND.(LNG.EQ.1))
00636      &               WRITE(LU,*) 'LECTURE DU PAS DE TEMPS :',
00637      &                 REAL(MESH2%TIMES(ITIME))
00638             IF(DEBUG.AND.(LNG.EQ.2))
00639      &               WRITE(LU,*) 'READING VALUES FOR TIME:',
00640      &                 REAL(MESH2%TIMES(ITIME))
00641             ! GET THE NUMBER OF VALUE FOR THIS FIELD
00642             CALL MFDNVA(NINP,FIELDNAME,ITIME,MED_NO_IT,TYPENT,TYPGEO,
00643      &                  NVAL,IERR)
00644             CALL FNCT_CHECK(IERR,'MFDNVA')
00645             IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)'NOMBRE DE VALEURS :',
00646      &                      NVAL
00647             IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)'NUMBER OF VALUES:',
00648      &                      NVAL
00649             IF (NVAL .EQ. 0) THEN
00650               IF(LNG.EQ.1) WRITE(LU,*) 'PAS DE VALEUR ',
00651      &                  MESH2%NAMEVAR(IVAR),
00652      &                  ' AU TEMPS :',MESH2%TIMES(ITIME)
00653               IF(LNG.EQ.2) WRITE(LU,*) 'NO VALUE FOR ',
00654      &                  MESH2%NAMEVAR(IVAR),
00655      &                  ' AT TIME:',MESH2%TIMES(ITIME)
00656             ENDIF
00657             ! USING A ANOTHER TABLE BECAUSE SOMTIMES (QUASI BUBBLE) THE
00658             ! TABLE IS BIGGER THAN IT SHOULD BE
00659             IF(NVAL.NE.MESH2%NPOIN) THEN
00660               IF(LNG.EQ.1) WRITE(LU,*)
00661      &                    'NOMBRE DE VALEURS DIFFERENT DE',
00662      &                    ' POINTS * NOMBRE OF COMPOSANT',
00663      &                    'NVAL :',NVAL,'NPOIN :',MESH2%NPOIN
00664               IF(LNG.EQ.2) WRITE(LU,*)
00665      &                    'NUMBER OF VALUES DIFFERENT FROM NUMBER OF',
00666      &                    ' POINTS * NUMBER OF COMPONENT',
00667      &                    'NVAL :',NVAL,'NPOIN :',MESH2%NPOIN
00668             ENDIF
00669             ! IF THERE ARE VALUE IN THE FIELD
00670             ! READING THE FILED VALUES IN THE MESH FILE
00671             IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00672      &                  'NOMBRE DE COMPOSANT :',NCOMP
00673             IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00674      &                  'NUMBER OF COMPONANT:',NCOMP
00675             ALLOCATE(RES(NVAL*NCOMP),STAT=IERR)
00676             CALL FNCT_CHECK(IERR,'ALLOCATE RES')
00677             DO J=1,NCOMP
00678               CALL MFDRVR(NINP,FIELDNAME,ITIME,MED_NO_IT,TYPENT,TYPGEO,
00679      &                    MED_NO_INTERLACE,J,RES,IERR)
00680               CALL FNCT_CHECK(IERR,'MFDRVR')
00681               MESH2%RESULTS(ITIME,IVAR+J-1,:) =
00682      &         RES((J-1)*MESH2%NPOIN+1:J*MESH2%NPOIN)
00683             ENDDO
00684             DEALLOCATE(RES)
00685             ! COPYING THE VALUES IN RESULTS
00686             IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00687      &                        '-FIN POUR LE PAS DE TEMPS',ITIME
00688             IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00689      &                        '-END FOR TIMESTEP',ITIME
00690           ENDDO
00691           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) '--FIN POUR VAR',I
00692           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) '--ENDING FOR VAR',I
00693           IVAR = IVAR + NCOMP
00694         ENDDO
00695       ENDIF
00696 
00697       CALL MFICLO(NINP,IERR)
00698       CALL FNCT_CHECK(IERR,'MFICLO')
00699 
00700       ! FILLING IB
00701       MESH2%IB(:)=0
00702       MESH2%IB(1)=1
00703       IF(ALLOCATED(MESH2%KNOLG)) MESH2%IB(8)=1
00704 !
00705 !-----------------------------------------------------------------------
00706 !
00707       WRITE(LU,*) '----------------------------------------------------'
00708       IF(LNG.EQ.1) WRITE(LU,*) '------FIN LECTURE DU FICHIER MED'
00709       IF(LNG.EQ.2) WRITE(LU,*) '------ENDING READING OF MED FILE'
00710       WRITE(LU,*) '----------------------------------------------------'
00711 #else
00712       IF(LNG.EQ.1) WRITE(LU,*)
00713      &       'ERREUR : TENTATIVE DE LECTURE D UN FICHIER MED ',
00714      &       'SANS LA BIBLIOTHEQUE'
00715       IF(LNG.EQ.2) WRITE(LU,*)
00716      &       'ERROR : TRYING TO READ MED FILE WITHOUT MED LIBRARY'
00717       CALL PLANTE(1)
00718 #endif
00719 ! ENDIF HAVE_MED
00720       END SUBROUTINE
00721 !                       *****************
00722                         SUBROUTINE WRITE_MED
00723 !                       *****************
00724      &(MEDFILE)
00725 !
00726 !***********************************************************************
00727 ! STBTEL   V6P1                                   11/07/2011
00728 !***********************************************************************
00729 !
00730 !BRIEF    WRITE A FILE OF MED FORMAT WITH THE MESH OBJECT
00731 !+        INFORMATIONS
00732 !
00733 !HISTORY  Y.AUDOUIN (EDF)
00734 !+        11/07/2011
00735 !+        V6P1
00736 !+   CREATION OF THE FILE
00737 !
00738 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00739 !| MEDFILE        |-->| NAME OF THE MED FILE
00740 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00741 !
00742       USE DECLARATIONS_STBTEL
00743       IMPLICIT NONE
00744       ! LANGAE AND OUTPUT VALUE
00745       INTEGER LNG,LU
00746       COMMON/INFO/LNG,LU
00747 !
00748 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00749 !
00750       CHARACTER(LEN=MAXLENHARD)  MEDFILE
00751 !
00752 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00753 !
00754 #if defined (HAVE_MED)
00755       INTEGER :: IERR,ITIME,IVAR
00756       INTEGER :: I,J,DIMVEC,NUMVEC
00757       INTEGER, ALLOCATABLE :: NUFANO(:), VECVAR(:)
00758       DOUBLE PRECISION, ALLOCATABLE :: COOR(:),RES(:)
00759       INTEGER :: TYPGEO
00760       CHARACTER(LEN=NAME_SIZE) :: MESHNAME
00761       CHARACTER(LEN=NAME_SIZE) :: FIELDNAME
00762       CHARACTER(LEN=SNAME_SIZE), ALLOCATABLE :: NAMEVAR(:),UNITVAR(:)
00763       INTEGER, ALLOCATABLE :: CON(:)
00764       LOGICAL :: ISVECTOR
00765       INTEGER :: TYPGEO2
00766       CHARACTER(LEN=NAME_SIZE) :: NAMEFAM,CDUM
00767       INTEGER :: NUMFAM,IDUM
00768       DOUBLE PRECISION :: DDUM
00769       CHARACTER(LEN=SNAME_SIZE) :: DTUNIT
00770       CHARACTER(LEN=SNAME_SIZE), ALLOCATABLE :: ELEMNAME(:)
00771       LOGICAL :: MYFALSE
00772 !
00773       WRITE(LU,*) '----------------------------------------------------'
00774       IF(LNG.EQ.1) WRITE(LU,*) '------DEBUT ECRITURE DU FICHIER MED'
00775       IF(LNG.EQ.2) WRITE(LU,*) '------BEGINNING WRITTING OF MED FILE'
00776       WRITE(LU,*) '----------------------------------------------------'
00777 !
00778 !-----------------------------------------------------------------------
00779 !
00780       ! WRITING THE MESH INFORMATIONS
00781 !
00782       ! CREATING THE FILE
00783       CALL MFIOPE(NOUT,MEDFILE,MED_ACC_CREAT,IERR)
00784       CALL FNCT_CHECK(IERR,'MFIOPE')
00785 !
00786       ! CREATING THE MESH
00787       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATIONS SUR LE MAILLAGE'
00788       IF(LNG.EQ.2) WRITE(LU,*) '---MESH INFORMATIONS'
00789       MESHNAME = 'MESH' // CHAR(0)
00790       ! IF WE HAVE NO DESCRIPTION SETTING THE TITLE AS DESCRIPTION
00791       IF(MESH2%DESCRIPTION(1:14).EQ.'NO DESCRIPTION') THEN
00792         MESH2%DESCRIPTION = ' '
00793         MESH2%DESCRIPTION = TRIM(MESH2%TITLE) // CHAR(0)
00794       ENDIF
00795       DTUNIT = "S"//CHAR(0)
00796       CALL MMHCRE(NOUT,MESHNAME,MESH2%NDIM,MESH2%NDIM,
00797      &            MED_UNSTRUCTURED_MESH,MESH2%DESCRIPTION,DTUNIT,
00798      &            MED_SORT_DTIT,MED_CARTESIAN,
00799      &            MESH2%NAMECOO,
00800      &            MESH2%UNITCOO,IERR)
00801       CALL FNCT_CHECK(IERR,'MMHCRE')
00802 !
00803       ! ADDING THE NODES COORDINATES
00804       ALLOCATE(COOR(MESH2%NPOIN*MESH2%NDIM),STAT=IERR)
00805       CALL FNCT_CHECK(IERR,"ALLOCATE COOR")
00806       DO I=1,MESH2%NPOIN
00807         COOR(I+0*MESH2%NPOIN) = MESH2%X(I)
00808         COOR(I+1*MESH2%NPOIN) = MESH2%Y(I)
00809         IF(MESH2%NDIM.EQ.3) THEN
00810           COOR(I+2*MESH2%NPOIN) = MESH2%Z(I)
00811         ENDIF
00812       ENDDO
00813       CALL MMHCOW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,DDUM,
00814      &            MED_NO_INTERLACE,MESH2%NPOIN,COOR,IERR)
00815       CALL FNCT_CHECK(IERR,'MMHCOW')
00816       DEALLOCATE(COOR)
00817 !
00818       ! ADDING THE ELEMENTS
00819       ! CONSTRUCTING IKLE FOR MED
00820       ALLOCATE(CON(MESH2%NELEM*MESH2%NDP),STAT=IERR)
00821       CALL FNCT_CHECK(IERR,'ALLOCATE CON')
00822       DO I=1,MESH2%NELEM
00823         DO J=1,MESH2%NDP
00824           CON(I+(J-1)*MESH2%NELEM) = MESH2%IKLES((I-1)*MESH2%NDP+J)
00825         ENDDO
00826       ENDDO
00827       SELECT CASE(MESH2%TYPE_ELEM)
00828       CASE(TYPE_TRIA3)
00829         TYPGEO = MED_TRIA3
00830       CASE(TYPE_QUAD4)
00831         TYPGEO = MED_QUAD4
00832       CASE(TYPE_TETRA4)
00833         TYPGEO = MED_TETRA4
00834       CASE(TYPE_PRISM6)
00835         TYPGEO = MED_PENTA6
00836       CASE DEFAULT
00837             IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : TYPE D ELEMENTS INCONNU'
00838             IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: UNKNOWN TYPE OF ELEMENTS'
00839         CALL PLANTE(1)
00840       END SELECT
00841       DDUM = 0.0
00842       ALLOCATE(ELEMNAME(MESH2%NELEM),STAT=IERR)
00843       CALL FNCT_CHECK(IERR,'ALLOCATE ELEMNAME')
00844       CALL MMHELW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,DDUM,
00845      &            MED_CELL,TYPGEO,MED_NODAL,
00846      &            MED_NO_INTERLACE,MESH2%NELEM,CON,MED_FALSE,ELEMNAME,
00847      &            MED_FALSE,IDUM,MED_FALSE,IDUM,IERR)
00848       CALL FNCT_CHECK(IERR,'MMHELW')
00849       DEALLOCATE(ELEMNAME)
00850       DEALLOCATE(CON)
00851       ! ADDING THE 2D ELEMENTS IF THEY EXIST (ESTEL)
00852       IF(MESH2%NELEM2.NE.0) THEN
00853         IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00854      &                 '-AJOUT D UN SECOND TYPE D ELEMENT'
00855         IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00856      &                 '-ADDING SECOND ELEMENT TYPE'
00857         ALLOCATE(CON(MESH2%NELEM2*MESH2%NDP2),STAT=IERR)
00858         CALL FNCT_CHECK(IERR,'ALLOCATE CON 2')
00859         DO I=1,MESH2%NELEM2
00860           DO J=1,MESH2%NDP2
00861             CON(I+(J-1)*MESH2%NELEM2) = MESH2%IKLES2((I-1)*MESH2%NDP2+J)
00862           ENDDO
00863         ENDDO
00864         SELECT CASE(MESH2%TYPE_ELEM2)
00865         CASE(TYPE_TRIA3)
00866           TYPGEO2 = MED_TRIA3
00867         CASE(TYPE_QUAD4)
00868           TYPGEO2 = MED_QUAD4
00869         CASE(TYPE_TETRA4)
00870           TYPGEO2 = MED_TETRA4
00871         CASE(TYPE_PRISM6)
00872           TYPGEO2 = MED_PENTA6
00873         CASE DEFAULT
00874             IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : TYPE D ELEMENTS INCONNU'
00875             IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: UNKNOWN TYPE OF ELEMENTS'
00876           CALL PLANTE(1)
00877         END SELECT
00878         ALLOCATE(ELEMNAME(MESH2%NELEM),STAT=IERR)
00879         CALL MMHELW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,DDUM,
00880      &              MED_CELL,TYPGEO2,MED_NODAL,
00881      &              MED_NO_INTERLACE,MESH2%NELEM2,CON,
00882      &              MED_FALSE,ELEMNAME,
00883      &              MED_FALSE,IDUM,MED_FALSE,IDUM,IERR)
00884         CALL FNCT_CHECK(IERR,'MMHELW')
00885         DEALLOCATE(CON,ELEMNAME)
00886       ENDIF
00887 !
00888       ! ADDING GLOBAL NUMBERING IF NECESSARY
00889       IF (MESH2%IB(8).NE.0 .OR. MESH2%IB(9).NE.0) THEN
00890         CALL MMHGNW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,
00891      &              MED_NONE,MESH2%NPOIN,MESH2%KNOLG,IERR)
00892         CALL FNCT_CHECK(IERR,"MMHGNW")
00893       ENDIF
00894 !
00895       ! BUILDING THE FAMILIES
00896       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATIONS SUR LES FAMILLES'
00897       IF(LNG.EQ.2) WRITE(LU,*) '---FAMILIES INFORMATIONS'
00898       ! CREATING THE ZERO FAMILY
00899       NAMEFAM='FAMILLE_ZERO'//CHAR(0)
00900       NUMFAM=0
00901       CALL MFACRE(NOUT,MESHNAME,NAMEFAM,NUMFAM,0,' ',IERR)
00902       CALL FNCT_CHECK(IERR,'MFACRE 0')
00903       IF(MESH2%NFAM.NE.0) THEN
00904         DO I=1,MESH2%NFAM
00905           CALL MFACRE(NOUT,MESHNAME,TRIM(MESH2%NAMEFAM(I))//CHAR(0),
00906      &                MESH2%IDFAM(I),MESH2%NGROUPFAM(I),
00907      &                MESH2%GROUPFAM(I,1:MESH2%NGROUPFAM(I)),IERR)
00908           CALL FNCT_CHECK(IERR,'MFACRE I')
00909         ENDDO
00910         ! IF WE HAVE BOUNDARY CONDITIONS
00911         IF (MESH2%NPTFR.NE.0) THEN
00912           ALLOCATE(NUFANO(MESH2%NPOIN),STAT=IERR)
00913           CALL FNCT_CHECK(IERR,'ALLOCATE NUFANO')
00914           ! WE NEED TO EXANGE THE VALUE WITH THE ID OF THE FAMILY
00915           DO J=1,MESH2%NPTFR
00916             I = 1
00917             DO WHILE(I.LE.MESH2%NFAM)
00918               ! WE TAKE ONLY FAMILIES ON NODES
00919               IF(MESH2%IDFAM(I).GT.0) THEN
00920                 IF(MESH2%LIHBOR(J).EQ.MESH2%VALFAM(I)) THEN
00921                   MESH2%LIHBOR(J)=MESH2%IDFAM(I)
00922                   I = MESH2%NFAM
00923                 ENDIF
00924               ENDIF
00925               I = I + 1
00926             ENDDO
00927           ENDDO
00928           ! BUILD THE FAMILY ID FOR EACH NODES 0 FOR NODES WITHOUT FAMILIES
00929           NUFANO(:) = 0
00930           DO I=1,MESH2%NPTFR
00931             NUFANO(MESH2%NBOR(I)) = MESH2%LIHBOR(I)
00932           ENDDO
00933           CALL MMHFNW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,
00934      &                MED_NONE,MESH2%NPOIN,NUFANO,IERR)
00935           CALL FNCT_CHECK(IERR,'MMHFNW NODE BOUNDARY')
00936           DEALLOCATE(NUFANO)
00937         ENDIF
00938         ! ADD THE FAMILY COLOR FOR EACH NODE (UNV) IF NO BOUNDARY
00939         ! CONDITIONS
00940         IF(ALLOCATED(MESH2%COLOR).AND.MESH2%NPTFR.EQ.0) THEN
00941           ! WE NEED TO REPLACE THE VAL BY THE FAMILY ID
00942           DO J= 1,MESH2%NPOIN
00943             I = 1
00944             DO WHILE(I.LE.MESH2%NFAM)
00945               ! WE ONLY DCONSIDER THE FAMILIES ON NODES (ID > 0)
00946               IF(MESH2%IDFAM(I).GT.0) THEN
00947                 IF(MESH2%COLOR(J).EQ.MESH2%VALFAM(I)) THEN
00948                   MESH2%COLOR(J)=MESH2%IDFAM(I)
00949                   ! FINISHING THE LOOP ON THE FAMILIES
00950                   I=MESH2%NFAM
00951                 ENDIF
00952               ENDIF
00953               I = I + 1
00954             ENDDO
00955           ENDDO
00956           CALL MMHFNW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,MED_NODE,
00957      &                MED_NONE,MESH2%NPOIN,MESH2%COLOR,IERR)
00958           CALL FNCT_CHECK(IERR,'MMHFNW NODES COLOR')
00959         ENDIF
00960         ! ADD THE FAMILY COLOR FOR EACH ELEMENT (ESTEL)
00961         IF(ALLOCATED(MESH2%NCOLOR)) THEN
00962           ! WE NEED TO REPLACE THE VAL BY THE FAMILY ID
00963           DO J= 1,MESH2%NELEM
00964             I=1
00965             ! ELEMENT FAMILY HAVE A NEGATIVE ID
00966             DO WHILE(I.LE.MESH2%NFAM)
00967               IF(MESH2%IDFAM(I).LT.0) THEN
00968                 IF(MESH2%NCOLOR(J).EQ.MESH2%VALFAM(I)) THEN
00969                   MESH2%NCOLOR(J)=MESH2%IDFAM(I)
00970                   ! END THE FAM LOOP
00971                   I=MESH2%NFAM
00972                 ENDIF
00973               ENDIF
00974               I = I + 1
00975             ENDDO
00976           ENDDO
00977           SELECT CASE (MESH2%TYPE_ELEM)
00978           CASE(TYPE_TRIA3)
00979             TYPGEO=MED_TRIA3
00980           CASE(TYPE_QUAD4)
00981             TYPGEO=MED_QUAD4
00982           CASE(TYPE_TETRA4)
00983             TYPGEO=MED_TETRA4
00984           CASE(TYPE_PRISM6)
00985             TYPGEO=MED_PENTA6
00986           END SELECT
00987           CALL MMHFNW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,
00988      &                TYPGEO,MESH2%NELEM,MESH2%NCOLOR,IERR)
00989           CALL FNCT_CHECK(IERR,'MMHFNW ELEM')
00990         ENDIF
00991         ! ADD THE FAMILY FOR EACH OTHER ELEMENT (ESTEL)
00992         IF(ALLOCATED(MESH2%NCOLOR2)) THEN
00993           ! WE NEED TO REPLACE THE VAL BY THE FAMILY ID
00994           DO J= 1,MESH2%NELEM2
00995             I=1
00996             ! ELEMENT FAMILY HAVE A NEGATIVE ID
00997             DO WHILE(I.LE.MESH2%NFAM)
00998               IF(MESH2%IDFAM(I).LT.0) THEN
00999                 IF(MESH2%NCOLOR2(J).EQ.MESH2%VALFAM(I)) THEN
01000                   MESH2%NCOLOR2(J)=MESH2%IDFAM(I)
01001                   ! END THE FAM LOOP
01002                   I=MESH2%NFAM
01003                 ENDIF
01004               ENDIF
01005               I = I + 1
01006             ENDDO
01007           ENDDO
01008           SELECT CASE (MESH2%TYPE_ELEM2)
01009           CASE(TYPE_TRIA3)
01010             TYPGEO=MED_TRIA3
01011           CASE(TYPE_QUAD4)
01012             TYPGEO=MED_QUAD4
01013           CASE(TYPE_TETRA4)
01014             TYPGEO=MED_TETRA4
01015           CASE(TYPE_PRISM6)
01016             TYPGEO=MED_PENTA6
01017           END SELECT
01018           CALL MMHFNW(NOUT,MESHNAME,MED_NO_DT,MED_NO_IT,MED_CELL,
01019      &                TYPGEO,MESH2%NELEM2,MESH2%NCOLOR2,IERR)
01020           CALL FNCT_CHECK(IERR,'MMHFNW ELEM2')
01021         ENDIF
01022       ENDIF
01023 !
01024       ! ADDING THE RESULTS
01025       ! BUILDING THE FIELDS
01026       IF(LNG.EQ.1) WRITE(LU,*) '---INFORMATIONS SUR LES REULTATS'
01027       IF(LNG.EQ.2) WRITE(LU,*) '---RESULTS INFORMATIONS'
01028       IF(MESH2%NVAR.NE.0) THEN
01029         DIMVEC=1
01030         ALLOCATE(VECVAR(MESH2%NDIM))
01031         CALL FNCT_CHECK(IERR,'ALLOCATE VECVAR')
01032         DO IVAR=1,MESH2%NVAR
01033           FIELDNAME = ''
01034           FIELDNAME = MESH2%NAMEVAR(IVAR) // CHAR(0)
01035           ! WE CHECK IF THE VARIABLE IS A VECTOR
01036           CALL IFVECTOR_(FIELDNAME,NUMVEC,ISVECTOR)
01037           ! IF SO WE KEEP THE VARAIBLE NUMBER AND
01038           IF(ISVECTOR) THEN
01039             VECVAR(NUMVEC) = IVAR
01040             ! IF NOT THE LAST COMPONENT SKIP TO NEXT VARAIBLE
01041             IF(NUMVEC.NE.MESH2%NDIM) CYCLE
01042             DIMVEC = NUMVEC
01043           ENDIF
01044           ALLOCATE(NAMEVAR(DIMVEC),STAT=IERR)
01045           CALL FNCT_CHECK(IERR,'ALLOCATE NAMEVAR')
01046           ALLOCATE(UNITVAR(DIMVEC),STAT=IERR)
01047           CALL FNCT_CHECK(IERR,'ALLOCATE UNITVAR')
01048           IF(ISVECTOR) THEN
01049             DO I=1,DIMVEC
01050               NAMEVAR(I) = MESH2%NAMEVAR(VECVAR(I))//CHAR(0)
01051               UNITVAR(I) = MESH2%UNITVAR(VECVAR(I))//CHAR(0)
01052             ENDDO
01053             VECVAR(:) = 0
01054           ELSE
01055             NAMEVAR(1) = MESH2%NAMEVAR(IVAR)//CHAR(0)
01056             UNITVAR(1) = MESH2%UNITVAR(IVAR)//CHAR(0)
01057           ENDIF
01058           CALL MFDCRE(NOUT,FIELDNAME,MED_FLOAT64,DIMVEC,NAMEVAR,
01059      &                UNITVAR,'S',MESHNAME,IERR)
01060           CALL FNCT_CHECK(IERR,'MFDCRE')
01061           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) '--POUR VARIABLE : ',
01062      &               FIELDNAME,DIMVEC
01063           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) '--FOR VARIABLE: ',
01064      &               FIELDNAME,DIMVEC
01065           DIMVEC = 1
01066           DEALLOCATE(NAMEVAR,UNITVAR)
01067         ENDDO
01068         ! ADD THE RESULT FOR EACH TIME STEP
01069         DO ITIME=1,MESH2%TIMESTEP
01070           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) '-POUR PAS DE TEMPS :',
01071      &        MESH2%TIMES(ITIME)
01072           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) '-FOR TIME STEP:',
01073      &        MESH2%TIMES(ITIME)
01074           DO IVAR=1,MESH2%NVAR
01075             FIELDNAME = ''
01076             FIELDNAME = MESH2%NAMEVAR(IVAR) // CHAR(0)
01077             CALL IFVECTOR_(FIELDNAME,NUMVEC,ISVECTOR)
01078             IF(ISVECTOR) THEN
01079               ! IF FIRST TIME WE ALLOCATE THE RESULT TABLE
01080               IF(NUMVEC.EQ.1) THEN
01081                 ALLOCATE(RES(MESH2%NPOIN*MESH2%NDIM),STAT=IERR)
01082                 CALL FNCT_CHECK(IERR,'ALLOCATE RES VECTOR')
01083               ENDIF
01084               ! WE ADD THE RESULTS TO THE RESULT TABLE
01085               RES((NUMVEC-1)*MESH2%NPOIN+1:(NUMVEC*MESH2%NPOIN)) =
01086      &            MESH2%RESULTS(ITIME,IVAR,:)
01087               ! IF NOT THE LAST COMPONENENT WE SKIP
01088               IF(NUMVEC.NE.MESH2%NDIM) CYCLE
01089               DIMVEC = NUMVEC
01090             ELSE
01091               ! IF A SCALAR FIELD
01092               ALLOCATE(RES(MESH2%NPOIN),STAT=IERR)
01093               CALL FNCT_CHECK(IERR,'ALLOCATE RES')
01094               RES(:) = MESH2%RESULTS(ITIME,IVAR,:)
01095               DIMVEC = 1
01096             ENDIF
01097             CALL MFDRVW(NOUT,FIELDNAME,ITIME,MED_NO_IT,
01098      &                  MESH2%TIMES(ITIME),MED_NODE,MED_NONE,
01099      &                  MED_NO_INTERLACE,MED_ALL_CONSTITUENT,
01100      &                  MESH2%NPOIN,RES,IERR)
01101             CALL FNCT_CHECK(IERR,'MFDRVW')
01102             DEALLOCATE(RES)
01103           ENDDO
01104         ENDDO
01105       ENDIF
01106 !
01107       CALL MFICLO(NOUT,IERR)
01108       CALL FNCT_CHECK(IERR,'MFICLO')
01109 !
01110 !-----------------------------------------------------------------------
01111 !
01112       WRITE(LU,*) '----------------------------------------------------'
01113       IF(LNG.EQ.1) WRITE(LU,*) '------FIN ECRITURE DU FICHIER MED'
01114       IF(LNG.EQ.2) WRITE(LU,*) '------ENDING WRITTING OF MED FILE'
01115       WRITE(LU,*) '----------------------------------------------------'
01116 #else
01117       IF(LNG.EQ.1) WRITE(LU,*)
01118      &     'ERREUR : TENTATIVE D ECRITURE D UN FICHIER MED ',
01119      &     'SANS BIBLIOTHEQUE'
01120       IF(LNG.EQ.2) WRITE(LU,*)
01121      &     'ERROR : TRYING TO WRITE MED FILE WITHOUT MED LIBRARY'
01122       CALL PLANTE(1)
01123 #endif
01124 ! ENDIF HAVE_MED
01125       END SUBROUTINE
01126 !
01127 #if defined(HAVE_MED)
01128       SUBROUTINE STB2MED_GEO(TYPE_ELEM,TYPGEO)
01129       USE DECLARATIONS_STBTEL
01130       IMPLICIT NONE
01131       ! LANGAE AND OUTPUT VALUE
01132       INTEGER LNG,LU
01133       COMMON/INFO/LNG,LU
01134       INTEGER TYPE_ELEM
01135       INTEGER TYPGEO
01136 !
01137       SELECT CASE(TYPE_ELEM)
01138       CASE(TYPE_TRIA3)
01139         TYPGEO = MED_TRIA3
01140       CASE(TYPE_QUAD4)
01141         TYPGEO = MED_QUAD4
01142       CASE(TYPE_TETRA4)
01143         TYPGEO = MED_TETRA4
01144       CASE(TYPE_PRISM6)
01145         TYPGEO = MED_PENTA6
01146       CASE DEFAULT
01147             IF(LNG.EQ.1) WRITE(LU,*) 'ERREUR : TYPE D ELEMENTS INCONNU'
01148             IF(LNG.EQ.2) WRITE(LU,*) 'ERROR: UNKNOWN TYPE OF ELEMENTS'
01149         CALL PLANTE(1)
01150       END SELECT
01151 
01152       END SUBROUTINE
01153 #endif
01154       END MODULE

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0