Télécharger gradia.eso

Retour à la liste

gradia
C GRADIA    SOURCE    CB215821  20/11/25    13:29:50     10792          
      SUBROUTINE GRADIA(ICEN,ISOMM,IFACEL,IFACEP,IMAIL,ISGLIM,
     &     ICHELM)
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
C     &        ,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)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMLREEL
-INC SMLENTI
-INC SMLMOTS
C
      INTEGER ISGLIM
     &       ,ICEN,ISOMM,IFACEL,IFACEP,IMAIL,IFACE,IFACE1
     &       ,ICHELM
 
C
      SEGMENT MLELEM
      INTEGER INDEX(NBL+1)
      INTEGER LESPOI(NBTPOI)
      ENDSEGMENT
      POINTEUR MLELSB.MLELEM, MLELSC.MLELEM, MLESBC.MLELEM,
     &     MLESCF.MLELEM,MLEFSC.MLELEM,
     &     MLRDIS.MLREEL, MLEFC.MLELEM
C
      INTEGER N1,N2
      SEGMENT MATRIX
      REAL*8 MAT(N1,N2)
      ENDSEGMENT
      POINTEUR MATCOE.MATRIX, MACOE1.MATRIX, MACOE2.MATRIX
C
C
C**** Ordonnement FACE, FACEL, FACEP avec le meme ordre
C
      CALL RLEORD(IFACEL,IFACEP,IFACE,IFACE1)
      IF(IERR .NE. 0)GOTO 9999
C
C**** test RLEORD
C
C      MELEME= IFACEP
C      IPT1 = IFACE1
C      SEGACT MELEME
C      SEGACT IPT1
C      NBSOUS=MELEME.LISOUS(/1)
C      JG=MAX(1,NBSOUS)
C      SEGINI MLENTI
C      IF(NBSOUS.EQ.0)THEN
C         MLENTI.LECT(1)=IFACEP
C      ELSE
C         DO I1 = 1, NBSOUS, 1
C            MLENTI.LECT(I1)=MELEME.LISOUS(I1)
C         ENDDO
C      ENDIF
C      NBSOUS=JG
C      IELEM=0
C      DO I1 = 1, NBSOUS, 1
C         IPT2=MLENTI.LECT(I1)
C         SEGACT IPT2
C         NBN=IPT2.NUM(/1)
C         NBE=IPT2.NUM(/2)
C         DO I2 = 1, NBE, 1
C            IELEM=IELEM+1
C            NGF=IPT2.NUM(NBN,I2)
C            NGF1=IPT1.NUM(2,IELEM)
C            write(ioimp,*) ngf, ngf1
C         ENDDO
C      ENDDO
C
C**** Fin test
C
      IFACEL=IFACE1
C
C     Ici on crée les MELEME IFACE, IFACEL (à eliminer)!
C
C**** Ls voisins type SOMMETS des sommets sur le bord
C
      CALL RLEXVB(IFACEL,IFACEP,ISOMM,MLELSB)
      IF(IERR.NE.0) GOTO 9999
C
C**** MLELSB =  LISTE SEQUENTIELLE INDEXEE D'ELEMENTS
C
C     NBL      : NOMBRE D'ELEMENTS
C     NBTPOI   : NOMBRE TOTAL DE POINTS REFERENCEES
C     INDEX(I) : INDICE DU 1ER POINT DU IEME ELEMENT
C                DANS LE TABLEAU LESPOI
C     LESPOI(INDEX(I) -> INDEX(I+1)-1) : NUMERO DES NOEUDS
C                DU IEME ELEMENT
C
C     NB: LESPOI contient de numero (globals) de noeuds
C         (voir RLEVFA)
C
C**** Test de RLEXVB
C
C      SEGACT MLELSB
C      MELEME = ISOMM
C      SEGACT MELEME
C      NBL=MLELSB.INDEX(/1)-1
C      NBTPOI=MLELSB.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLELSB.INDEX(I1)
C         NGV=MLELSB.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGV = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         NVOIS= MLELSB.INDEX(I1+1) -  MLELSB.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLELSB.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C         ENDDO
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C**** Ls voisins type CENTRE des sommets
C
      CALL RLEXVC(IMAIL,ICEN,ISOMM,MLELSC)
      IF(IERR .NE. 0) GOTO 9999
C
C**** MLELSC =  LISTE SEQUENTIELLE INDEXEE D'ELEMENTS
C     (avec des numeros globals de noeuds)
C
C**** Test de RLEXVC
C
C      SEGACT MLELSC
C      MELEME = ISOMM
C      SEGACT MELEME
C      NBL=MLELSC.INDEX(/1)-1
C      NBTPOI=MLELSC.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLELSC.INDEX(I1)
C         NGV=MLELSC.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGV = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         NVOIS= MLELSC.INDEX(I1+1) -  MLELSC.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLELSC.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C         ENDDO
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C      Pour les points de bords on va chercher les centres voisins des
C      voisins et on va le mettre en ordre decroissante pas raport a la
C      distance
C
C     MLESBC = sommet de bord - centres voisins de sommets voisins,
C              ordonné apar distance
C     MLRDIS = LISTREEL qui contient les distances aux carré
C
C     En RLEVB1 on detrui MLELSB (= sommet de bord - sommets voisins)
C
      CALL RLEVB1(ISOMM,ICEN,MLELSC,MLELSB,MLESBC,MLRDIS)
      IF(IERR.NE.0)GOTO 9999
C
C**** Test de RLEVB1
C
C      SEGACT MLRDIS
C      SEGACT MLESBC
C      MELEME = ISOMM
C      SEGACT MELEME
C      NBL=MLESBC.INDEX(/1)-1
C      NBTPOI=MLESBC.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLESBC.INDEX(I1)
C         NGV=MLESBC.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGV = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         NVOIS= MLESBC.INDEX(I1+1) -  MLESBC.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLESBC.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C            WRITE(IOIMP,*) MLRDIS.PROG(IPOS+I2)
C         ENDDO
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C
C**** On cree: MLESCF : sommet - centres "voisins"  (F = final)
C              MATCOE : MATIRCE qui contient les coeff pour
C                       la projection CENTRE -> SOMMET
C
C     On detrui MLELSC, MLESBC, MLRDIS
C
      CALL RLEXCA(ISGLIM,MLELSC,MLESBC,MLRDIS,MLESCF,MATCOE)
      IF(IERR.NE.0) GOTO 9999
C
C**** Test de RLEXCA
C
C      SEGACT MLESCF
C      SEGACT MATCOE
C      MELEME = ISOMM
C      SEGACT MELEME
C      JG=IDIM+1
C      SEGINI MLREE1
C      NBL=MLESCF.INDEX(/1)-1
C      NBTPOI=MLESCF.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLESCF.INDEX(I1)
C         NGV=MLESCF.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGV = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         WRITE(IOIMP,*)
C     &        'Coeff(',NGV,')=',(MATCOE.MAT(I3,IPOS),I3=1,IDIM+1)
C         DO I3=1,IDIM+1
C            MLREE1.PROG(I3)=MATCOE.MAT(I3,IPOS)
C         ENDDO
C         NVOIS= MLESCF.INDEX(I1+1) -  MLESCF.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLESCF.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C            WRITE(IOIMP,*)
C     &           'Coeff(',NGV1,')=',(MATCOE.MAT(I3,IPOI),I3=1,IDIM+1)
C            DO I3=1,IDIM+1
C               MLREE1.PROG(I3)=MLREE1.PROG(I3)+MATCOE.MAT(I3,IPOI)
C            ENDDO
C         ENDDO
C         WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1)
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C**** On cree: MLEFSC : centre de face - (sommets - centres) voisins
C              MACOE1 : MATRICE  qui contient les coeff pour
C                       la projection CENTRE, SOMMET -> FACE
C
      CALL RLECA1(IFACEL,IFACEP,MLEFSC,MACOE1)
      IF(IERR.NE.0)GOTO 9999
C
C**** Test de RLECA1
C
C      SEGACT MLEFSC
C      SEGACT MACOE1
C      JG=IDIM+1
C      SEGINI MLREE1
C      NBL=MLEFSC.INDEX(/1)-1
C      NBTPOI=MLEFSC.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLEFSC.INDEX(I1)
C         NGV=MLEFSC.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGF = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         WRITE(IOIMP,*)
C     &        'Coeff(',NGV,')=',(MACOE1.MAT(I3,IPOS),I3=1,IDIM+1)
C         DO I3=1,IDIM+1
C            MLREE1.PROG(I3)=MACOE1.MAT(I3,IPOS)
C         ENDDO
C         NVOIS= MLEFSC.INDEX(I1+1) -  MLEFSC.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLEFSC.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C            WRITE(IOIMP,*)
C     &           'Coeff(',NGV1,')=',(MACOE1.MAT(I3,IPOI),I3=1,IDIM+1)
C            DO I3=1,IDIM+1
C               MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE1.MAT(I3,IPOI)
C            ENDDO
C         ENDDO
C         WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1)
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C
C**** RLEXFI
C
C     Creation du MLELEM qui contient
C     Points faces - voisins centres
C
      CALL RLEXFI(MLESCF,MATCOE,MLEFSC,MACOE1,MLEFC,MACOE2)
C
C**** Test de RLEXFI
C
C      SEGACT MLEFC
C      SEGACT MACOE2
C      JG=IDIM
C      SEGINI MLREE1
C      MELEME = ISOMM
C      SEGACT MELEME
C      NBL=MLEFC.INDEX(/1)-1
C      NBTPOI=MLEFC.LESPOI(/1)
C      IPOI=0
C      DO I1 = 1, NBL, 1
C         IPOI=IPOI+1
C         WRITE(IOIMP,*) I1
C         IPOS=MLEFC.INDEX(I1)
C         NGV=MLEFC.LESPOI(IPOS)
C         WRITE(IOIMP,*) 'NGV = ', NGV
C         WRITE(IOIMP,*) ' Position ', IPOS
C         WRITE(IOIMP,*)
C     &        'Coeff(',NGV,')=',(MACOE2.MAT(I3,IPOS),I3=1,IDIM)
C         DO I3=1,IDIM
C            MLREE1.PROG(I3)=MACOE2.MAT(I3,IPOS)
C         ENDDO
C         NVOIS= MLEFC.INDEX(I1+1) -  MLEFC.INDEX(I1) - 1
C         WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS
C         DO I2 = 1, NVOIS, 1
C            IPOI=IPOI+1
C            NGV1=MLEFC.LESPOI(IPOS+I2)
C            WRITE(IOIMP,*)  NGV1
C            WRITE(IOIMP,*)
C     &           'Coeff(',NGV1,')=',(MACOE2.MAT(I3,IPOI),I3=1,IDIM)
C            DO I3=1,IDIM
C               MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE2.MAT(I3,IPOI)
C            ENDDO
C         ENDDO
C         WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM)
C      ENDDO
C      WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI
C
C***** Fin test
C
C
C**** Creation de MCHAML
C     MLEFC, MACOE2 -> MCHAML
C
      CALL RLEXCO(MLEFC,MACOE2,ICHELM)
      IF(IERR.NE.0)GOTO 9999
C
C**** On detrui le FACEL et IFAC ici crée
C
      MELEME=IFACEL
      SEGSUP MELEME
      MELEME=IFACE
      SEGSUP MELEME
C
 9999 CONTINUE
      RETURN
      END
 
 
 
 
 
 
 
 
 
 

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