conv_unv.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\conv_unv.f
00002 !
00039       MODULE CONV_UNV
00040       CONTAINS
00041 !                       *****************
00042                         SUBROUTINE READ_UNV
00043 !                       *****************
00044      &(UNVFILE,LOGFILE2)
00045 !
00046 !***********************************************************************
00047 ! STBTEL   V6P1                                   11/07/2011
00048 !***********************************************************************
00049 !
00050 !BRIEF    READS A FILE OF UNV FORMAT AND FILL THE MESH OBJECT
00051 !
00052 !HISTORY  Y.AUDOUIN (EDF)
00053 !+        11/07/2011
00054 !+        V6P1
00055 !+   CREATION OF THE FILE
00056 !
00057 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00058 !| UNVFILE        |-->| NAME OF THE UNV FILE IN THE TEMPORARY FOLDER
00059 !| LOGFILE2       |-->| NAME OF THE LOG FILE IN THE TEMPORARY FOLDER
00060 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00061 !
00062       USE DECLARATIONS_STBTEL
00063 !
00064       IMPLICIT NONE
00065       ! LANGAE AND OUTPUT VALUE
00066       INTEGER LNG,LU
00067       COMMON/INFO/LNG,LU
00068 !
00069 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00070 !
00071       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: UNVFILE
00072       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: LOGFILE2
00073 !
00074 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00075 !
00076       INTEGER :: IERR
00077       INTEGER :: IB(6),I,J,IDUM
00078       LOGICAL :: READ_NSEC1,READ_NSEC2,READ_NSEC3
00079       INTEGER :: ELEM, NSEC
00080       INTEGER, PARAMETER :: TITLE_SEC=151
00081       INTEGER, PARAMETER :: COOR_SEC=2411
00082       INTEGER, PARAMETER :: CONN_SEC=2412
00083       CHARACTER*200 :: LINE
00084       INTEGER :: POS
00085       INTEGER :: VALUES(MAXFAM)
00086       INTEGER :: IELEM, IELEM2, NELEMTOTAL
00087       INTEGER, ALLOCATABLE :: TEMPO(:)
00088       INTEGER, ALLOCATABLE :: TMP(:)
00089       INTEGER :: ICOLOR
00090       CHARACTER*4 :: BLANC
00091       CHARACTER*2 :: MOINS1
00092       INTEGER :: NFAMNODE,NFAMELEM
00093       CHARACTER*32, ALLOCATABLE :: TMP_NAMEFAM(:)
00094       INTEGER, ALLOCATABLE :: TMP_IDFAM(:)
00095       INTEGER, ALLOCATABLE :: TMP_VALFAM(:)
00096       INTEGER, ALLOCATABLE :: TMP_NGROUPFAM(:)
00097       CHARACTER(LEN=LNAME_SIZE), ALLOCATABLE :: TMP_GROUPFAM(:,:)
00098 !
00099       WRITE(LU,*) '----------------------------------------------------'
00100       IF(LNG.EQ.1) WRITE(LU,*) '------DEBUT LECTURE DU FICHIER UNV'
00101       IF(LNG.EQ.2) WRITE(LU,*) '------BEGINNING READING OF UNV FILE'
00102       WRITE(LU,*) '----------------------------------------------------'
00103 !
00104 !-----------------------------------------------------------------------
00105 !
00106       IDUM=0
00107       ! READING THE LOG FILE FIRST IT CONTAINS THE GENERIC INFORMATIONS
00108       OPEN(NLOG,IOSTAT=IERR,FILE=LOGFILE2,FORM='FORMATTED')
00109       CALL FNCT_CHECK(IERR,'OPEN '//TRIM(LOGFILE2))
00110 !
00111       ! THE FIRST LINE CONTAINS THE NUMBER OF NODES AFTER A TEXT DESCRIPTOR.
00112       ! WE READ A LINE, LOCATE THE COLON ':' TO THEN READ THE NUMBER.
00113       READ(NLOG,'(A200)') LINE
00114       POS =INDEX(LINE,':') + 1
00115       READ(UNIT=LINE(POS:),FMT=*) MESH2%NPOIN
00116       IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOMBRE DE POINTS : ',
00117      &         MESH2%NPOIN
00118       IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NUMBER OF POINT: ',
00119      &         MESH2%NPOIN
00120 !
00121       ! THE SECOND LINE CONTAINS THE NUMBER OF ELEMENTS AFTER A TEXT DESCRIPTOR.
00122       ! WE READ A LINE, LOCATE THE COLON ':' AND THEN READ THE NUMBER.
00123       READ(NLOG,'(A200)') LINE
00124       POS =INDEX(LINE,':') + 1
00125       READ(UNIT=LINE(POS:),FMT=*) NELEMTOTAL
00126       IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'NOMBRE D ELEMENTS : ',
00127      &         NELEMTOTAL
00128       IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'NUMBER OF ELEMENTS: ',
00129      &         NELEMTOTAL
00130 !
00131       CLOSE(NLOG,IOSTAT=IERR)
00132       CALL FNCT_CHECK(IERR,'CLOSE '//TRIM(LOGFILE2))
00133 !
00134       ! READING THE UNV FILE
00135       OPEN(NINP,IOSTAT=IERR,FILE=UNVFILE,FORM='FORMATTED')
00136       CALL FNCT_CHECK(IERR,'OPEN '//TRIM(UNVFILE))
00137       READ_NSEC1=.FALSE.
00138       READ_NSEC2=.FALSE.
00139       READ_NSEC3=.FALSE.
00140 !
00141       DO WHILE (.NOT. (READ_NSEC1.AND.READ_NSEC2.AND.READ_NSEC3))
00142         ! READING UNTIL WE FIND A SECTION
00143         MOINS1 = '  '
00144         BLANC  = '1111'
00145         DO WHILE (MOINS1.NE.'-1' .OR. BLANC.NE.'    ')
00146           READ(NINP,'(A4,A2)') BLANC,MOINS1
00147         ENDDO
00148         ! READING THE SECTION NUMBER
00149         NSEC=-1
00150         DO WHILE (NSEC.EQ.-1)
00151           READ(NINP,*) NSEC
00152         ENDDO
00153         ! DEPENDING OF THE SECTION
00154         SELECT CASE(NSEC)
00155         CASE(TITLE_SEC)
00156           IF(LNG.EQ.1) WRITE(LU,*) '---SECTION TITRE'
00157           IF(LNG.EQ.2) WRITE(LU,*) '---TITLE SECTION'
00158           ! READING THE MESH TITLE
00159           READ(NINP,'(A80)') LINE
00160           LINE=ADJUSTL(LINE)
00161           MESH2%TITLE = LINE(1:72)
00162           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*) 'TITRE : ',MESH2%TITLE
00163           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*) 'TITLE : ',MESH2%TITLE
00164           READ_NSEC1=.TRUE.
00165         CASE(COOR_SEC)
00166           IF(LNG.EQ.1) WRITE(LU,*) '---SECTION COORDONNEES'
00167           IF(LNG.EQ.2) WRITE(LU,*) '---COORDINATES SECTION'
00168           ! READING THE COORDINATES AND THE COLOR OF THE NODES
00169           ALLOCATE(MESH2%X(MESH2%NPOIN),STAT=IERR)
00170           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%X')
00171           ALLOCATE(MESH2%Y(MESH2%NPOIN),STAT=IERR)
00172           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%Y')
00173           ALLOCATE(MESH2%Z(MESH2%NPOIN),STAT=IERR)
00174           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%Z')
00175           ALLOCATE(MESH2%COLOR(MESH2%NPOIN),STAT=IERR)
00176           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%COLOR')
00177           ALLOCATE(TEMPO(MESH2%NPOIN),STAT=IERR)
00178           CALL FNCT_CHECK(IERR,'ALLOCATE TEMPO')
00179           NFAMNODE = 0
00180           VALUES = 0
00181           DO I=1,MESH2%NPOIN
00182             READ(NINP,*) J,IDUM,IDUM,MESH2%COLOR(I)
00183             TEMPO(J) = I
00184             IF(MESH2%COLOR(I).NE.0) THEN
00185               ! TEST IF IT'S A NEW COLOR
00186               IF(COUNT(VALUES.EQ.MESH2%COLOR(I)).EQ.0) THEN
00187                 NFAMNODE = NFAMNODE + 1
00188                 VALUES(NFAMNODE) = MESH2%COLOR(I)
00189               ENDIF
00190             ENDIF
00191             READ(NINP,*) MESH2%X(I), MESH2%Y(I), MESH2%Z(I)
00192           ENDDO
00193           ! BUIDING THE FAMILIES IN TEMPORARY TABLES
00194           ! BECAUSE WE HAVE TO WANT FOR THE FAMILIES ON ELEMENTS
00195           IF(DEBUG.AND.(LNG.EQ.1)) WRITE(LU,*)
00196      &          'NOMBRE DE FAMILLES SUR LES NOEUDS : ',NFAMNODE
00197           IF(DEBUG.AND.(LNG.EQ.2)) WRITE(LU,*)
00198      &          'NUMBER OF NODES FAMILIES: ',NFAMNODE
00199           ALLOCATE(TMP_IDFAM(NFAMNODE),STAT=IERR)
00200           CALL FNCT_CHECK(IERR,'ALLOCATE TMP_IDFAM')
00201           ALLOCATE(TMP_NAMEFAM(NFAMNODE),STAT=IERR)
00202           CALL FNCT_CHECK(IERR,'ALLOCATE TMP_NAMEFAM')
00203           ALLOCATE(TMP_VALFAM(NFAMNODE),STAT=IERR)
00204           CALL FNCT_CHECK(IERR,'ALLOCATE TMP_VALFAM')
00205           ALLOCATE(TMP_NGROUPFAM(NFAMNODE),STAT=IERR)
00206           CALL FNCT_CHECK(IERR,'ALLOCATE TMP_NGROUPFAM')
00207           ALLOCATE(TMP_GROUPFAM(NFAMNODE,10),STAT=IERR)
00208           CALL FNCT_CHECK(IERR,'ALLOCATE TMP_GROUPFAM')
00209           DO I=1,NFAMNODE
00210             TMP_IDFAM(I) = I
00211             TMP_VALFAM(I) = VALUES(I)
00212             TMP_NAMEFAM(I) = 'FAM_COLOR_NODES_'//TRIM(I2CHAR(VALUES(I)))
00213             TMP_NGROUPFAM(I) = 1
00214             TMP_GROUPFAM(I,1) = 'COLOR_NODES_'//TRIM(I2CHAR(VALUES(I)))
00215             IF(DEBUG) WRITE(LU,*) 'NAMEFAM: ',TMP_NAMEFAM(I)
00216             IF(DEBUG) WRITE(LU,*) 'IDFAM  : ',TMP_IDFAM(I)
00217             IF(DEBUG) WRITE(LU,*) 'VALFAM : ',TMP_VALFAM(I)
00218             IF(DEBUG) WRITE(LU,*) 'NGROUP : ',TMP_NGROUPFAM(I)
00219             IF(DEBUG) WRITE(LU,*) 'GROUPS : ',TRIM(TMP_GROUPFAM(I,1))
00220           ENDDO
00221           READ_NSEC2=.TRUE.
00222         CASE(CONN_SEC)
00223           IF(LNG.EQ.1) WRITE(LU,*) '---SECTION CONNECTIVITE'
00224           IF(LNG.EQ.2) WRITE(LU,*) '---CONNECTIVITY SECTION'
00225           ! READING THE CONNECTIVITY TABLE (IKLES)
00226           ! DEPENDING OF THE TYPE OF THE ELEMENT WE ARE FILLING IKLES
00227           ! OR IKLES2
00228           ! WE HAVE TO ALLOCATE THE TABLE TO THEIR MAXIMUN SIZE BECAUSE
00229           ! WE DON'T KNOW THE REAL SIZE
00230           ALLOCATE(MESH2%IKLES(NELEMTOTAL*6),STAT=IERR)
00231           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES')
00232           ALLOCATE(MESH2%IKLES2(NELEMTOTAL*6),STAT=IERR)
00233           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES2')
00234           ALLOCATE(MESH2%NCOLOR(NELEMTOTAL),STAT=IERR)
00235           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR')
00236           ALLOCATE(MESH2%NCOLOR2(NELEMTOTAL),STAT=IERR)
00237           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR2')
00238           ! READING THE CONNECTIVITY
00239           IELEM = 0
00240           IELEM2 = 0
00241           DO I=1,NELEMTOTAL
00242             READ(NINP,*) NSEC,ELEM,IDUM,IDUM,ICOLOR,IDUM
00243             ! IF WE ARE AT THE END OF THE CONNECTIVITY INFORMATIONS
00244             IF(NSEC.EQ.-1) THEN
00245               IF(LNG.EQ.2) THEN
00246                 WRITE(LU,*) 'NUMBER OF ELEMENTS NON VALID IN LOG FILE'
00247                 WRITE(LU,*) 'IS:',NELEMTOTAL
00248                 WRITE(LU,*) 'SHOULD BE:',IELEM+IELEM2
00249               ENDIF
00250               IF(LNG.EQ.2) THEN
00251                 WRITE(LU,*) 'NOMBRE ELEMENT ERRONEE DANS LE FICHIER LOG'
00252                 WRITE(LU,*) 'IL YA :',NELEMTOTAL, 'ELEMENTS'
00253                 WRITE(LU,*) 'DEVRAIT Y AVOIR :',IELEM+IELEM2
00254               ENDIF
00255               READ_NSEC3 = .TRUE.
00256               CYCLE
00257             ENDIF
00258             SELECT CASE (ELEM)
00259             ! TRIANGLE
00260             CASE (91,41)
00261               IELEM2 = IELEM2 + 1
00262               MESH2%TYPE_ELEM2 = TYPE_TRIA3
00263               MESH2%NDP2 = 3
00264               READ(NINP,*)(IB(J),J=1,MESH2%NDP2)
00265               DO J=1,MESH2%NDP2
00266                 MESH2%IKLES2((IELEM2-1)*MESH2%NDP2+J) = TEMPO(IB(J))
00267               ENDDO
00268               MESH2%NCOLOR2(IELEM2) = ICOLOR
00269             ! SQUARE
00270             CASE (44,94)
00271               IELEM2 = IELEM2 + 1
00272               MESH2%TYPE_ELEM2 = TYPE_QUAD4
00273               MESH2%NDP2 = 4
00274               READ(NINP,*)(IB(J),J=1,MESH2%NDP2)
00275               DO J=1,MESH2%NDP2
00276                 MESH2%IKLES2((IELEM2-1)*MESH2%NDP2+J) = TEMPO(IB(J))
00277               ENDDO
00278               MESH2%NCOLOR2(IELEM2) = ICOLOR
00279             ! TETRAEDRON
00280             CASE (111)
00281               IELEM = IELEM + 1
00282               MESH2%TYPE_ELEM = TYPE_TETRA4
00283               MESH2%NDP = 4
00284               READ(NINP,*)(IB(J),J=1,MESH2%NDP)
00285               DO J=1,MESH2%NDP
00286                 MESH2%IKLES((IELEM-1)*MESH2%NDP+J) = TEMPO(IB(J))
00287               ENDDO
00288               MESH2%NCOLOR(IELEM) = ICOLOR
00289             ! PRISM
00290             CASE (112)
00291               IELEM = IELEM + 1
00292               MESH2%TYPE_ELEM = TYPE_PRISM6
00293               MESH2%NDP = 6
00294               READ(NINP,*)(IB(J),J=1,MESH2%NDP)
00295               DO J=1,MESH2%NDP
00296                 MESH2%IKLES((IELEM-1)*MESH2%NDP+J) = TEMPO(IB(J))
00297               ENDDO
00298               MESH2%NCOLOR(IELEM) = ICOLOR
00299             CASE DEFAULT
00300               IF(LNG.EQ.1) WRITE(LU,*) 'TYPE UNV INCONNU :',ELEM
00301               IF(LNG.EQ.2) WRITE(LU,*) 'UNKNOWN UNV TYPE:',ELEM
00302               CALL PLANTE(1)
00303             END SELECT
00304           ENDDO
00305           DEALLOCATE(TEMPO)
00306           ! IF NO 3D ELEMENTS
00307           IF(IELEM.EQ.0) THEN
00308             ! IT MEANS WE ARE IN 2D
00309             MESH2%NDIM = 2
00310             ! WE DON'T NEED Z
00311             DEALLOCATE(MESH2%Z)
00312             ! RECOPY
00313             MESH2%NELEM = IELEM2
00314             MESH2%TYPE_ELEM = MESH2%TYPE_ELEM2
00315             MESH2%NDP = MESH2%NDP2
00316             DEALLOCATE(MESH2%NCOLOR)
00317             ALLOCATE(MESH2%NCOLOR(MESH2%NELEM),STAT=IERR)
00318             CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR BIS')
00319             MESH2%NCOLOR = MESH2%NCOLOR2(1:MESH2%NELEM)
00320             DEALLOCATE(MESH2%IKLES)
00321             ALLOCATE(MESH2%IKLES(MESH2%NELEM*MESH2%NDP),STAT=IERR)
00322             CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES BIS')
00323             MESH2%IKLES = MESH2%IKLES2(1:MESH2%NELEM*MESH2%NDP)
00324             ! DESTROY
00325             DEALLOCATE(MESH2%IKLES2)
00326             DEALLOCATE(MESH2%NCOLOR2)
00327             MESH2%NDP2 = 0
00328             MESH2%TYPE_ELEM2 = 0
00329             MESH2%NELEM2 = 0
00330           ELSE
00331             MESH2%NELEM = IELEM
00332             MESH2%NELEM2 = IELEM2
00333             MESH2%NDIM = 3
00334             MESH2%IB(7) = 1
00335             ! IF WE HAVE 2D ELEMENTS
00336             IF(IELEM2.NE.0) THEN
00337               ! RESIZE THE IKLES AND COLOR TABLE TABLES
00338               ALLOCATE(TMP(MAX(MESH2%NELEM2*MESH2%NDP2,
00339      &                 MESH2%NELEM*MESH2%NDP)),STAT=IERR)
00340               CALL FNCT_CHECK(IERR,'ALLOCATE TMP')
00341               !IKLES
00342               TMP(1:MESH2%NELEM*MESH2%NDP) =
00343      &            MESH2%IKLES(1:MESH2%NELEM*MESH2%NDP)
00344               DEALLOCATE(MESH2%IKLES)
00345               ALLOCATE(MESH2%IKLES(MESH2%NELEM*MESH2%NDP),STAT=IERR)
00346               CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES BIS')
00347               MESH2%IKLES = TMP(1:MESH2%NELEM*MESH2%NDP)
00348               ! IKLES2
00349               TMP(1:MESH2%NELEM2*MESH2%NDP2) =
00350      &            MESH2%IKLES2(1:MESH2%NELEM2*MESH2%NDP2)
00351               DEALLOCATE(MESH2%IKLES2)
00352               ALLOCATE(MESH2%IKLES2(MESH2%NELEM2*MESH2%NDP2),STAT=IERR)
00353               CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IKLES2 BIS')
00354               MESH2%IKLES2 = TMP(1:MESH2%NELEM2*MESH2%NDP2)
00355               ! NCOLOR
00356               TMP(1:MESH2%NELEM) = MESH2%NCOLOR(1:MESH2%NELEM)
00357               DEALLOCATE(MESH2%NCOLOR)
00358               ALLOCATE(MESH2%NCOLOR(MESH2%NELEM),STAT=IERR)
00359               CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR BIS')
00360               MESH2%NCOLOR = TMP(1:MESH2%NELEM)
00361               ! NCOLOR2
00362               TMP(1:MESH2%NELEM2) = MESH2%NCOLOR2(1:MESH2%NELEM2)
00363               DEALLOCATE(MESH2%NCOLOR2)
00364               ALLOCATE(MESH2%NCOLOR2(MESH2%NELEM2),STAT=IERR)
00365               CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NCOLOR2 BIS')
00366               MESH2%NCOLOR2 = TMP(1:MESH2%NELEM2)
00367               DEALLOCATE(TMP)
00368             ENDIF
00369           ENDIF
00370           IF(DEBUG) WRITE(LU,*) 'NDIM : ',MESH2%NDIM
00371           ! FINDING THE NEW FAMILIES
00372           NFAMELEM = 0
00373           VALUES(:) = 0
00374           DO I=1,MESH2%NELEM
00375             ! TEST IF IT'S A NEW COLOR
00376             IF(COUNT(VALUES.EQ.MESH2%NCOLOR(I)).EQ.0) THEN
00377               NFAMELEM = NFAMELEM + 1
00378               VALUES(NFAMELEM) = MESH2%NCOLOR(I)
00379             ENDIF
00380           ENDDO
00381           IF(MESH2%NELEM2.NE.0) THEN
00382             DO I=1,MESH2%NELEM2
00383               ! TEST IF IT'S A NEW COLOR
00384               IF(COUNT(VALUES.EQ.MESH2%NCOLOR2(I)).EQ.0) THEN
00385                 NFAMELEM = NFAMELEM + 1
00386                 VALUES(NFAMELEM) = MESH2%NCOLOR2(I)
00387               ENDIF
00388             ENDDO
00389           ENDIF
00390           MESH2%NFAM = NFAMNODE + NFAMELEM
00391           ! ALLOCATAING THE TABLE
00392           ALLOCATE(MESH2%IDFAM(MESH2%NFAM),STAT=IERR)
00393           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IDFAM')
00394           ALLOCATE(MESH2%NAMEFAM(MESH2%NFAM),STAT=IERR)
00395           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NAMEFAM')
00396           ALLOCATE(MESH2%VALFAM(MESH2%NFAM),STAT=IERR)
00397           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%VALFAM')
00398           ALLOCATE(MESH2%NGROUPFAM(MESH2%NFAM),STAT=IERR)
00399           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%VALFAM')
00400           ALLOCATE(MESH2%GROUPFAM(MESH2%NFAM,1),STAT=IERR)
00401           CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%VALFAM')
00402           ! COPYING NODES FAMILY FROM THE TMP TABLES
00403           DO I=1,NFAMNODE
00404             MESH2%IDFAM(I) = TMP_IDFAM(I)
00405             MESH2%NAMEFAM(I) = TMP_NAMEFAM(I)
00406             MESH2%VALFAM(I) = TMP_VALFAM(I)
00407             MESH2%NGROUPFAM(I) = TMP_NGROUPFAM(I)
00408             MESH2%GROUPFAM(I,1) = TMP_GROUPFAM(I,1)
00409           ENDDO
00410           DEALLOCATE(TMP_GROUPFAM,TMP_NGROUPFAM,TMP_IDFAM,
00411      &               TMP_VALFAM,TMP_NAMEFAM)
00412           ! ADDING HE ELEMENTS FAMILIES
00413           DO I=1,NFAMELEM
00414             MESH2%IDFAM(I+NFAMNODE) = -I
00415             MESH2%NAMEFAM(I+NFAMNODE) =
00416      &            'FAM_COLOR_FACES_'//TRIM(I2CHAR(VALUES(I)))
00417             MESH2%VALFAM(I+NFAMNODE) = VALUES(I)
00418             MESH2%NGROUPFAM(I+NFAMNODE) = 1
00419             MESH2%GROUPFAM(I+NFAMNODE,1) =
00420      &            'COLOR_FACES_'//TRIM(I2CHAR(VALUES(I)))
00421             IF(DEBUG) WRITE(LU,*) 'NAMEFAM: ',MESH2%NAMEFAM(I+NFAMNODE)
00422             IF(DEBUG) WRITE(LU,*) 'IDFAM : ',MESH2%IDFAM(I+NFAMNODE)
00423             IF(DEBUG) WRITE(LU,*) 'VALFAM: ',MESH2%VALFAM(I+NFAMNODE)
00424             IF(DEBUG) WRITE(LU,*)'NGROUP : ',MESH2%NGROUPFAM(I+NFAMNODE)
00425             IF(DEBUG) WRITE(LU,*)'GROUP : ',MESH2%GROUPFAM(I+NFAMNODE,1)
00426           ENDDO
00427           READ_NSEC3=.TRUE.
00428         CASE DEFAULT
00429           IF(LNG.EQ.1) WRITE(LU,*) 'SECTION UNV INCONNUE :',NSEC
00430           IF(LNG.EQ.2) WRITE(LU,*) 'UNKNOWN UNV SECTION:',NSEC
00431         END SELECT
00432       ENDDO
00433       ! FILLING THE MISSING INFORMATIONS
00434       ALLOCATE(MESH2%IPOBO(MESH2%NPOIN),STAT=IERR)
00435       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%IPOBO')
00436       MESH2%IPOBO(:) = 0
00437       ALLOCATE(MESH2%NAMECOO(MESH2%NDIM),STAT=IERR)
00438       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%NAMECOO')
00439       ALLOCATE(MESH2%UNITCOO(MESH2%NDIM),STAT=IERR)
00440       CALL FNCT_CHECK(IERR,'ALLOCATE MESH2%UNITCOO')
00441       MESH2%NAMECOO(1) = 'X'
00442       MESH2%UNITCOO(1) = 'M'
00443       MESH2%NAMECOO(2) = 'Y'
00444       MESH2%UNITCOO(2) = 'M'
00445       IF(MESH2%NDIM.EQ.3) THEN
00446         MESH2%NAMECOO(3) = 'Z'
00447         MESH2%UNITCOO(3) = 'M'
00448         ! CHANGING IB IF IN 3D
00449         MESH2%IB(7) = 1
00450       ENDIF
00451       DO I=1,MESH2%NDIM
00452         CALL BLANC2USCORE(MESH2%NAMECOO(I),16)
00453         CALL BLANC2USCORE(MESH2%UNITCOO(I),16)
00454       ENDDO
00455 !
00456       CLOSE(NINP,IOSTAT=IERR)
00457       CALL FNCT_CHECK(IERR,'CLOSE '//TRIM(UNVFILE))
00458 !
00459 !-----------------------------------------------------------------------
00460 !
00461       WRITE(LU,*) '----------------------------------------------------'
00462       IF(LNG.EQ.1) WRITE(LU,*) '------FIN LECTURE DU FICHIER UNV'
00463       IF(LNG.EQ.2) WRITE(LU,*) '------ENDING READING OF UNV FILE'
00464       WRITE(LU,*) '----------------------------------------------------'
00465       END SUBROUTINE
00466 !                       *****************
00467                         SUBROUTINE WRITE_UNV
00468 !                       *****************
00469      &(UNVFILE,LOGFILE2)
00470 !
00471 !***********************************************************************
00472 ! STBTEL   V6P1                                   11/07/2011
00473 !***********************************************************************
00474 !
00475 !BRIEF    WRITE A FILE OF UNV FORMAT AND WITH THE MESH OBJECT
00476 !+        INFORMATIONS
00477 !
00478 !HISTORY  Y.AUDOUIN (EDF)
00479 !+        11/07/2011
00480 !+        V6P1
00481 !+   CREATION OF THE FILE
00482 !
00483 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00484 !| UNVFILE        |-->| NAME OF THE UNV FILE
00485 !| LOGFILE2       |-->| NAME OF THE LOG FILE
00486 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00487 !
00488       USE DECLARATIONS_STBTEL
00489 !
00490       IMPLICIT NONE
00491       ! LANGAE AND OUTPUT VALUE
00492       INTEGER LNG,LU
00493       COMMON/INFO/LNG,LU
00494 !
00495 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00496 !
00497       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: UNVFILE
00498       CHARACTER(LEN=MAXLENHARD), INTENT(IN) :: LOGFILE2
00499 !
00500 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00501 !
00502       INTEGER, PARAMETER :: TITLE_SEC=151
00503       INTEGER, PARAMETER :: COOR_SEC=2411
00504       INTEGER, PARAMETER :: CONN_SEC=2412
00505       INTEGER :: IB(6),I,J,IERR
00506       DOUBLE PRECISION :: XB(3)
00507       CHARACTER*80 :: TITLE2
00508       INTEGER, ALLOCATABLE :: NCOLOR(:)
00509       INTEGER, ALLOCATABLE :: MYVALFAM(:)
00510       INTEGER, ALLOCATABLE :: SORT(:)
00511       INTEGER :: ELEM
00512       INTEGER :: TEMPMIN
00513       INTEGER :: POS(1)
00514 !
00515       WRITE(LU,*) '----------------------------------------------------'
00516       IF(LNG.EQ.1) WRITE(LU,*) '------DEBUT ECRITURE DU FICHIER UNV'
00517       IF(LNG.EQ.2) WRITE(LU,*) '------BEGINNING WRITTING OF UNV FILE'
00518       WRITE(LU,*) '----------------------------------------------------'
00519 !
00520 !-----------------------------------------------------------------------
00521 !
00522       NOUT = 666
00523       OPEN(NOUT,IOSTAT=IERR,FILE=LOGFILE2,STATUS='NEW',FORM='FORMATTED')
00524       CALL FNCT_CHECK(IERR,'OPEN '//TRIM(LOGFILE2))
00525       WRITE(NOUT,*) 'TOTAL NO. OF NODES                   :',MESH2%NPOIN
00526       WRITE(NOUT,*) 'TOTAL NO. OF ELEMENTS                :',
00527      &              MESH2%NELEM+MESH2%NELEM2
00528       IF(MESH2%NFAM.NE.0) THEN
00529         WRITE(NOUT,*)'TOTAL NO. OF FAMILIES                :',MESH2%NFAM
00530         WRITE(NOUT,*) 'LIST OF FAMILIES, FAMILY_ID, COLOR_ID :'
00531         DO I=1,MESH2%NFAM
00532           WRITE(NOUT,'(A,A2,I4,A1,I4)') MESH2%NAMEFAM(I),' :',
00533      &                 MESH2%IDFAM(I),',',MESH2%VALFAM(I)
00534         ENDDO
00535         ALLOCATE(MYVALFAM(MESH2%NFAM))
00536         ALLOCATE(SORT(MESH2%NFAM))
00537         MYVALFAM = MESH2%VALFAM
00538         SORT = -1
00539         I = 0
00540         TEMPMIN = MINVAL(MYVALFAM)
00541         DO WHILE (TEMPMIN.LT.100)
00542           I = I + 1
00543           SORT(I) = TEMPMIN
00544           POS = MINLOC(MYVALFAM)
00545           DO WHILE (MYVALFAM(POS(1)).EQ.TEMPMIN)
00546             MYVALFAM(POS(1)) = 100
00547             POS = MINLOC(MYVALFAM)
00548           ENDDO
00549           TEMPMIN = MINVAL(MYVALFAM)
00550         ENDDO
00551         WRITE(NOUT,*) 'NUMBER OF EXTERNAL FACES         :',
00552      &                I-1
00553         WRITE(NOUT,*) 'PRIORITY FOR THE EXTERNAL FACES  :',
00554      &     (SORT(J),J=2,I)
00555         DEALLOCATE(MYVALFAM)
00556         DEALLOCATE(SORT)
00557       ELSE
00558         WRITE(NOUT,*) 'TOTAL NO. OF FAMILIES                :  0'
00559         WRITE(NOUT,*) 'LIST OF FAMILIES, FAMILY_ID, COLOR_ID :'
00560         WRITE(NOUT,*) 'NUMBER OF EXTERNAL FACES         :'
00561         WRITE(NOUT,*) 'PRIORITY FOR THE EXTERNAL FACES  :'
00562       ENDIF
00563 
00564       CLOSE(NOUT,IOSTAT=IERR)
00565       CALL FNCT_CHECK(IERR,'CLOSE '//TRIM(LOGFILE2))
00566 
00567       OPEN(NOUT,IOSTAT=IERR,FILE=UNVFILE,STATUS='NEW',FORM='FORMATTED')
00568       CALL FNCT_CHECK(IERR,'OPEN '//TRIM(UNVFILE))
00569 !
00570       ! WRITTING SECTION 1 TITLE
00571       IF(LNG.EQ.1) WRITE(LU,*) '---ECRITURE DE LA SECTION TITRE'
00572       IF(LNG.EQ.2) WRITE(LU,*) '---WRITTING TITLE SECTION'
00573       WRITE(NOUT,'(I6)') -1
00574       WRITE(NOUT,'(I6)') TITLE_SEC
00575       ! WRINTNG THE TITLE
00576       TITLE2 = MESH2%TITLE
00577       WRITE(NOUT,*) TITLE2
00578       ! END OF SECTION
00579       WRITE(NOUT,'(I6)') -1
00580 !
00581       ! WRITTING SECTION 2 COORDINATES AND COLOR
00582       IF(LNG.EQ.1) WRITE(LU,*) '---ECRITURE DE LA SECTION COORDONEES'
00583       IF(LNG.EQ.2) WRITE(LU,*) '---WRITTING COORDINATES SECTION'
00584       WRITE(NOUT,'(I6)') -1
00585       WRITE(NOUT,'(I6)') COOR_SEC
00586       ! REBUILDING THE NCOLOR TABLE
00587       ALLOCATE(NCOLOR(MESH2%NPOIN),STAT=IERR)
00588       CALL FNCT_CHECK(IERR,'ALLOCATE NCOLOR POINT')
00589       ! IF COLOR EXIST THEN WE COPY ELSE SET TO 1
00590       IF(ALLOCATED(MESH2%COLOR)) THEN
00591         NCOLOR = MESH2%COLOR
00592       ELSE
00593         NCOLOR(:) = 1
00594       ENDIF
00595       ! WRITTING INFORMATIONS FOR EACH POINT
00596       DO I=1,MESH2%NPOIN
00597         WRITE(NOUT,'(4I10)') I,1,1,NCOLOR(I)
00598         XB(1) = MESH2%X(I)
00599         XB(2) = MESH2%Y(I)
00600         IF(MESH2%NDIM.EQ.2) THEN
00601           XB(3) = 0.D0
00602         ELSE
00603           XB(3) = MESH2%Z(I)
00604         ENDIF
00605         WRITE(NOUT,'(3D25.16)') XB(1),XB(2),XB(3)
00606       ENDDO
00607       DEALLOCATE(NCOLOR)
00608       ! END OF SECTION
00609       WRITE(NOUT,'(I6)') -1
00610 !
00611       ! WRITTING SECTION 3 CONNECTIVITY TABLE
00612       IF(LNG.EQ.1) WRITE(LU,*) '---ECRITURE DE LA SECTION CONNECTIVITE'
00613       IF(LNG.EQ.2) WRITE(LU,*) '---WRITTING CONNECTIVITY SECTION'
00614       WRITE(NOUT,'(I6)') -1
00615       WRITE(NOUT,'(I6)') CONN_SEC
00616       ! IDENTIFY THE UNV TYPE NUMBER
00617       SELECT CASE(MESH2%TYPE_ELEM)
00618       CASE(TYPE_TRIA3)
00619         ELEM = 91
00620       CASE(TYPE_QUAD4)
00621         ELEM = 94
00622       CASE(TYPE_TETRA4)
00623         ELEM = 111
00624       CASE(TYPE_PRISM6)
00625         ELEM = 112
00626       END SELECT
00627       ALLOCATE(NCOLOR(MESH2%NELEM),STAT=IERR)
00628       CALL FNCT_CHECK(IERR,'ALLOCATE NCOLOR ELEM')
00629       ! IF COLOR EXIST THEN WE COPY ELSE SET TO 1
00630       IF(ALLOCATED(MESH2%NCOLOR)) THEN
00631         NCOLOR = MESH2%NCOLOR
00632       ELSE
00633         NCOLOR(:) = 1
00634       ENDIF
00635       DO I=1,MESH2%NELEM
00636         WRITE(NOUT,'(6I10)') I,ELEM,1,1,NCOLOR(I),MESH2%NDP
00637         DO J=1,MESH2%NDP
00638           IB(J) = MESH2%IKLES((I-1)*MESH2%NDP+J)
00639         ENDDO
00640         ! Estel 3d convention we need to swap order 1 and 2 for tetrahedron
00641         IF (ELEM.EQ.111) THEN
00642           IERR = IB(1)
00643           IB(1) = IB(2)
00644           IB(2) = IERR
00645         ENDIF
00646         WRITE(NOUT,'(6I10)') (IB(J),J=1,MESH2%NDP)
00647       ENDDO
00648       DEALLOCATE(NCOLOR)
00649       ! DOING IT FOR THE 2D ELEMENTS IF THEY EXIST
00650       IF(MESH2%NELEM2.NE.0) THEN
00651         SELECT CASE(MESH2%TYPE_ELEM2)
00652         CASE(TYPE_TRIA3)
00653           ELEM = 91
00654         CASE(TYPE_QUAD4)
00655           ELEM = 94
00656         CASE(TYPE_TETRA4)
00657           ELEM = 111
00658         CASE(TYPE_PRISM6)
00659           ELEM = 112
00660         END SELECT
00661         ALLOCATE(NCOLOR(MESH2%NELEM2),STAT=IERR)
00662         CALL FNCT_CHECK(IERR,'ALLOCATE NCOLOR ELEM2')
00663         ! IF COLOR EXIST THEN WE COPY ELSE SET TO 1
00664         IF(ALLOCATED(MESH2%NCOLOR2)) THEN
00665           NCOLOR = MESH2%NCOLOR2
00666         ELSE
00667           NCOLOR(:) = 1
00668         ENDIF
00669         DO I=1,MESH2%NELEM2
00670           WRITE(NOUT,'(6I10)') I+MESH2%NELEM,ELEM,1,1,
00671      &                         NCOLOR(I),MESH2%NDP2
00672           DO J=1,MESH2%NDP2
00673             IB(J) = MESH2%IKLES2((I-1)*MESH2%NDP2+J)
00674           ENDDO
00675           WRITE(NOUT,'(6I10)') (IB(J),J=1,MESH2%NDP2)
00676         ENDDO
00677         DEALLOCATE(NCOLOR)
00678       ENDIF
00679       ! END OF SECTION
00680       WRITE(NOUT,'(I6)') -1
00681 !
00682       CLOSE(NOUT,IOSTAT=IERR)
00683       CALL FNCT_CHECK(IERR,'CLOSE '//TRIM(UNVFILE))
00684 !
00685 !-----------------------------------------------------------------------
00686 !
00687       WRITE(LU,*) '----------------------------------------------------'
00688       IF(LNG.EQ.1) WRITE(LU,*) '------FIN ECRITURE DU FICHIER UNV'
00689       IF(LNG.EQ.2) WRITE(LU,*) '------ENDING WRITTING OF UNV FILE'
00690       WRITE(LU,*) '----------------------------------------------------'
00691       END SUBROUTINE
00692       END MODULE

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