lectri.f

Go to the documentation of this file.

!                       *****************
                        SUBROUTINE lectri
!                       *****************
!
     & (x, y, ikle, ncolor,ngeo , nfo1)
!
!***********************************************************************
! PROGICIEL : STBTEL V5.2          18/08/93   P. LANG  (LHF)
!***********************************************************************
!
!     FONCTION  : LECTURE DES INFOS DE GEOMETRIE DANS LES FICHIERS TRIGR
!
!-----------------------------------------------------------------------
!                             ARGUMENTS
! .________________.____.______________________________________________
! !      NOM       !MODE!                   ROLE
! !________________!____!______________________________________________
! ! X,Y            !<-- ! COORDONNEES DES POINTS DU MAILLAGE
! ! IKLE           !<-- ! NUMEROS GLOBAUX DES NOEUDS DE CHAQUE ELEMENT
! ! NCOLOR         !<-- ! TABLEAU DES COULEURS DES NOEUDS(POUR LES CL)
! ! NGEO           !--> ! NUMERO DU CANAL DU FICHIER MAILLEUR
! ! NFO1           !--> ! NUMERO DU CANAL DU FICHIER TRIANGLE TRIGRID
! !________________!____!______________________________________________
! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
!-----------------------------------------------------------------------
! APPELE PAR :
! APPEL DE :
!***********************************************************************
!
      USE declarations_special
      USE declarations_stbtel, ONLY: nelem,npoin,nelmax
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: NGEO, NFO1
      INTEGER, INTENT(INOUT) :: IKLE(nelmax,4)
      INTEGER, INTENT(INOUT) :: NCOLOR(*)
      DOUBLE PRECISION, INTENT(INOUT) :: X(*), Y(*)
!
      INTEGER ITYPND,NUMNOD,I,J
!
! COMMON
!
!
      rewind(ngeo)
      rewind(nfo1)
      READ (ngeo,'(//)')
      DO i=1,npoin
        READ (ngeo,*,err=8000,end=9000) numnod,x(i),y(i),itypnd
        IF (itypnd.EQ.1) ncolor(i) = 11
        IF (itypnd.EQ.2) ncolor(i) = 4
        IF (itypnd.EQ.3) ncolor(i) = 5
        IF (itypnd.EQ.4) ncolor(i) = 7
        IF (itypnd.EQ.5) ncolor(i) = 8
        IF (itypnd.EQ.6) ncolor(i) = 9
        IF (itypnd.EQ.7) ncolor(i) = 1
        IF (itypnd.EQ.8) ncolor(i) = 12
        IF (itypnd.EQ.9) ncolor(i) = 15
        IF (itypnd.EQ.10) ncolor(i) = 2
        IF (itypnd.EQ.11) ncolor(i) = 3
        IF (itypnd.EQ.12) ncolor(i) = 14
        IF (itypnd.EQ.13) ncolor(i) = 13
      ENDDO
!
      DO i=1,nelem
        READ (nfo1, * , err=8010, end=9010) (ikle(i,j),j=1,3)
      ENDDO
      RETURN
 8000 CONTINUE
      WRITE (lu,4001)
 4001 FORMAT (//,1x,'****************************'
     &        ,/,1x,'SUBROUTINE LECTRI :'
     &        ,/,1x,'ERROR READING TRIGRID FILE.'
     &        ,/,1x,'****************************')
      CALL plante(1)
      stop
 9000 CONTINUE
      WRITE (lu,4011)
 4011 FORMAT (//,1x,'***************************************'
     &        ,/,1x,'SUBROUTINE LECTRI : UNEXPECTED END OF'
     &        ,/,1x,'TRIGRID FILE ENCOUNTERED'
     &        ,/,1x,'***************************************')
      CALL plante(1)
      stop
 8010 CONTINUE
      WRITE (lu,4021)
 4021 FORMAT (//,1x,'***************************************'
     &        ,/,1x,'SUBROUTINE LECTRI : ERROR READING'
     &        ,/,1x,'TRIGRID TRIANGLE FILE'
     &        ,/,1x,'***************************************')
      CALL plante(1)
      stop
 9010 CONTINUE
      WRITE (lu,4031)
 4031 FORMAT (//,1x,'***************************************'
     &        ,/,1x,'SUBROUTINE LECTRI : END OF'
     &        ,/,1x,'TRIGRID TRIANGLE FILE ENCOUNTERED'
     &        ,/,1x,'***************************************')
      CALL plante(1)
      stop
      END