Télécharger rlevb1.eso

Retour à la liste

rlevb1
C RLEVB1    SOURCE    CHAT      05/01/13    03:01:51     5004
      SUBROUTINE RLEVB1(MELSOM,MELCEN,MLELSC,MLELSB,MLESBC,MLRDIS)
C
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
CC     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
C
      IMPLICIT INTEGER(I-N)
      INTEGER  NCEN,I1,NMAXCE,ICEL,NMAXS,LAST,IPLSB1,IPLSB2
     &        ,NGS,NLS,NSVOI,IPLSC1,IPLSC2,NGS1,ICEL1,NCVOI,NGC,NLC
     &        ,I2,IPOS,NLS1,NTOTCV,NGS2,IPCOOR,I3,NCMIS
      REAL*8 XS,YS,ZS,DXC,DYC,DZC, DIST2, DIST21
C
-INC SMELEME
      INTEGER JG
-INC SMLENTI
-INC SMLREEL
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
C
      INTEGER NBL, NBTPOI
      SEGMENT MLELEM
      INTEGER INDEX(NBL+1)
      INTEGER LESPOI(NBTPOI)
      ENDSEGMENT
      POINTEUR MLELSC.MLELEM, MLELSB.MLELEM, MLESBC.MLELEM
C
      POINTEUR MELSOM.MELEME, MELCEN.MELEME
C
      POINTEUR MLESOM.MLENTI, MLECEN.MLENTI
     &        ,MLECVO.MLENTI
      POINTEUR MLRDIS.MLREEL
C
C**** Le MELEME SOMMET
C
      CALL KRIPAD(MELSOM,MLESOM)
C
C     MLESOM: numerotation globale -> locale
C
C**** En KRIPAD
C     SEGACT MELSOM
C     SEGINI MLESOM
C
C**** Le MELEME CENTRE
C
      CALL KRIPAD(MELCEN,MLECEN)
C
C     MLECEN: numerotation globale -> locale
C
C**** En KRIPAD
C     SEGACT MELCEN
C     SEGINI MLECEN
C
      NCEN=MELCEN.NUM(/2)
C
      NMAXCE=0
      SEGACT MLELSC
      NBL=MLELSC.INDEX(/1)-1
      DO I1 = 1, NBL, 1
         ICEL=MLELSC.INDEX(I1+1)-MLELSC.INDEX(I1)-1
         NMAXCE=MAX(NMAXCE,ICEL)
      ENDDO
C
      SEGACT MLELSB
      NMAXS=0
      NBL=MLELSB.INDEX(/1)-1
      DO I1 = 1, NBL, 1
         ICEL=MLELSB.INDEX(I1+1)-MLELSB.INDEX(I1)-1
         NMAXS=MAX(NMAXS,ICEL)
      ENDDO
C
C**** NBL de MLELSB = NBL de MLESBC
C     Surestimation des noeuds en MLESBC
C
      NBTPOI=(NBL+1)*(NMAXCE*NMAXS)
      SEGINI MLESBC
      JG=NBTPOI
      SEGINI MLRDIS
C
C**** MLRDIS = dedans la structure MLESBC, distance (au carre)
C              premier noeud et ses voisins
C
C
C**** MLECVO + LAST = liste chaînée des centres voisins
C                       d'un sommet au bord
      JG=NCEN
      SEGINI MLECVO
      LAST=-1
C
C**** Soit NGS un sommet sur le bord.
C     Je dois créer la liste des centres voisins
C     des sommets voisins à NGS
C     Cette liste est ordonnée par rapport à la distance
C     centre-NGS
C     Cette liste ne doit pas contenir la liste des centres
C     voisins à NGS
C
C
C     NBTPOI = le vrai nombre de point de MLESBC
      NBTPOI=0
C
C**** IPLSB1 (IPLSB2) = position de NGS dans la structure MLELSB
C     IPOS = position de NGS dans la structure MLESBC
C
      IPLSB2=1
      IPOS=1
      DO I1 = 1, NBL, 1
C
C******* Les sommets voisins de NGS
C
         IPLSB1=IPLSB2
         IPLSB2=MLELSB.INDEX(I1+1)
         NSVOI=IPLSB2-IPLSB1-1
C
C******* Numero global et local du sommets NGS
C
         NGS=MLELSB.LESPOI(IPLSB1)
         NLS=MLESOM.LECT(NGS)
         MLESBC.INDEX(I1)=IPOS
         MLESBC.LESPOI(IPOS)=NGS
         MLRDIS.PROG(IPOS)=0.0D0
C
C******* On remplie la liste chaînée avec les centres voisins de NGS
C        Ces centres ne doivent pas apparaitre dedans MLESBC
C
         IPLSC1=MLELSC.INDEX(NLS)
         IPLSC2=MLELSC.INDEX(NLS+1)
         NGS1=MLELSC.LESPOI(IPLSC1)
         IF(NGS1 .NE. NGS)THEN
C
C********** Erreur de programmation
C           En effet, par construction, le position de NGS dans la
C           structure MLELSC est la meme que dans MELSOM
C
            WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
            CALL ERREUR(5)
            GOTO 9999
         ENDIF
         NCVOI=IPLSC2-IPLSC1-1
         DO I2 = 1, NCVOI, 1
            NGC=MLELSC.LESPOI(IPLSC1+I2)
            NLC=MLECEN.LECT(NGC)
            IF((NLC.EQ.0).OR.(MLECVO.LECT(NLC).NE.0))THEN
C
C********** Erreur de programmation
C
               WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
               CALL ERREUR(5)
               GOTO 9999
            ELSE
               MLECVO.LECT(NLC)=LAST
               LAST=NLC
            ENDIF
         ENDDO
C
C******* Les centre voisins de sommets voisins
C
         NTOTCV=0
C
C******* Boucle sur les sommets voisins
C
         DO I2 = 1, NSVOI, 1
            NGS1=MLELSB.LESPOI(IPLSB1+I2)
            NLS1=MLESOM.LECT(NGS1)
            IPLSC1=MLELSC.INDEX(NLS1)
            IPLSC2=MLELSC.INDEX(NLS1+1)
            NGS2=MLELSC.LESPOI(IPLSC1)
            IF(NGS1 .NE. NGS2)THEN
               WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
            NCVOI=IPLSC2-IPLSC1-1
            DO I3 = 1, NCVOI, 1
               NGC=MLELSC.LESPOI(IPLSC1+I3)
               NLC=MLECEN.LECT(NGC)
               IF(NLC.EQ.0)THEN
C
C************* Erreur de programmation
C
                  WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
                  CALL ERREUR(5)
                  GOTO 9999
               ELSEIF(MLECVO.LECT(NLC).EQ.0)THEN
                  MLECVO.LECT(NLC)=LAST
                  LAST=NLC
                  NTOTCV=NTOTCV+1
               ENDIF
            ENDDO
         ENDDO
C
C******* La structure MLECVO + LAST contient NTOTCV centres voisins
C        des sommets sommets voisins à NGS + les centres de NGS
C        Il faut le mettre en ordre par raport à la distance
C
         IPCOOR=(IDIM+1)*(NGS-1)+1
         XS=MCOORD.XCOOR(IPCOOR)
         YS=MCOORD.XCOOR(IPCOOR+1)
         IF(IDIM.EQ.3) ZS=MCOORD.XCOOR(IPCOOR+2)
         NCMIS=0
         DO I2 = 1, NTOTCV, 1
            NLC=LAST
            LAST=MLECVO.LECT(NLC)
            MLECVO.LECT(NLC)=0
            NGC=MELCEN.NUM(1,NLC)
            IPCOOR=(IDIM+1)*(NGC-1)+1
            DXC=MCOORD.XCOOR(IPCOOR)-XS
            DYC=MCOORD.XCOOR(IPCOOR+1)-YS
            DZC=0.0D0
            IF(IDIM.EQ.3) DZC=MCOORD.XCOOR(IPCOOR+2)-ZS
            DIST2=(DXC*DXC)+(DYC*DYC)+(DZC*DZC)
C
C********** Position avec la methode directe
C
            ICEL=1
 10         CONTINUE
            IF(ICEL .GT. NCMIS)THEN
               NCMIS=NCMIS+1
               MLESBC.LESPOI(IPOS+ICEL)=NGC
               MLRDIS.PROG(IPOS+ICEL)=DIST2
            ELSE
               DIST21=MLRDIS.PROG(IPOS+ICEL)
               IF(DIST21 .GT. DIST2)THEN
                  NCMIS=NCMIS+1
                  ICEL1=IPOS+NCMIS
                  DO I3 =  0, NCMIS - ICEL - 1
                     MLESBC.LESPOI(ICEL1-I3)=MLESBC.LESPOI(ICEL1-I3-1)
                     MLRDIS.PROG(ICEL1-I3)=MLRDIS.PROG(ICEL1-I3-1)
                  ENDDO
                  MLESBC.LESPOI(IPOS+ICEL)=NGC
                  MLRDIS.PROG(IPOS+ICEL)=DIST2
               ELSE
                  ICEL=ICEL+1
                  GOTO 10
               ENDIF
            ENDIF
         ENDDO
         IF(NCMIS .NE. NTOTCV)THEN
            CALL ERREUR(5)
            GOTO 9999
         ENDIF
C
C******* On nettoie MLECVO
C
 20      CONTINUE
         IF(LAST.GT.0)THEN
            NLC=LAST
            LAST=MLECVO.LECT(NLC)
            MLECVO.LECT(NLC)=0
            GOTO 20
         ELSEIF(LAST .NE. -1)THEN
            CALL ERREUR(5)
            GOTO 9999
         ENDIF
C
C******* Mise a jour de NBTPOI
C
         NBTPOI=NBTPOI+NCMIS
         IPOS=IPOS+NCMIS+1
      ENDDO
      NBTPOI=NBTPOI+NBL
      MLESBC.INDEX(NBL+1)=IPOS
C
C**** MLESBC surdimensionné
C
      SEGADJ MLESBC
      JG=NBTPOI
      SEGADJ MLRDIS
C
      SEGDES MLESBC
      SEGDES MLELSC
      SEGSUP MLELSB
C
      SEGDES MLESOM
      SEGSUP MLESOM
      SEGDES MELCEN
      SEGSUP MLECEN
C
      SEGSUP MLECVO
      SEGDES MLRDIS
 
 9999 RETURN
      END
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales