Sources Esope | Cast3M

ella01
C ELLA01    SOURCE    CHAT      05/01/12    23:33:44     5004
      SUBROUTINE ELLA01(NELEXP,NP2,NFRQ,ITEXP,MATRES)
C
      IMPLICIT INTEGER(I-N)
-INC SMLREEL
-INC SMTABLE
-INC SMELEME
C
      POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
C
C     LECTURE DE LA TABLE DES ELEMENTS EXPERIMENTAUX
C
C     MODULE DECODANT DES LISTES REELLES DE COEFFICIENTS
C     EXPERIMENTAUX
C
C     TEXP = TABLE 'TAB_EXPERIMENTALE' ;
C
C     TLT . MAILLAGE = TABLE 'ELEMENT_EXPERIMENTAL' ;
C     TEXP . MAILLAGE = TLT(JELEM) ;
C
C     LA LONGUEUR DE LA TABLE TEXP EST EGALE A :
C     1 + NOMBRE D'ELEMENTS EXPERIMENTAUX
C
C POINTEUR DE MOT                                     : MTABII(1)
C POINTEUR DE MAILLAGE DU 1 ER MAILLAGE EXPERIMENTAL  : MTABII(2)
C POINTEUR DE MAILLAGE DU 2 EME MAILLAGE EXPERIMENTAL : MTABII(3)
C POINTEUR DE MAILLAGE DU JELEM EME MAILLAGE EXPERIMENTAL : MTABII(JTAB)
C
C   POINTEUR DE TABLE DU 1 ER MAILLAGE EXPERIMENTAL  : MTABIV(2)
C   POINTEUR DE TABLE DU 2 EME MAILLAGE EXPERIMENTAL : MTABIV(3)
C   POINTEUR DE TABLE DU JELEM EME MAILLAGE EXPERIMENTAL : MTABIV(JTAB)
C
C     1 &lt; JLIGNE &lt; 14
C     TE(JELEM)L(JLIGN) = TABLE 'LIGNE' ;
C     TLT(JELEM) . JLIGN = TE(JELEM)L(JLIGN) ;
C
C     1 &lt; JCOLO &lt; 28
C     1     -> RUXA  : PARTIE REELLE DE UXA
C     2     -> RUYA
C     .........
C     JCOLO -> COMP(JCOLO)
C     .........
C     28    -> RQTB
C     29    -> IUXA  : PARTIE IMAGINAIRE DE UXA
C     .........
C     JCOLO+28 -> COMP(JCOLO+28)
C     .........
C     56    -> IQTB
C
C     ENTREES :
C             - NELEXP : NOMBRE D'ELEMENTS EXPERIMENTAUX
C             - NFRQ   : NOMBRE DE POINTS EN FREQUENCE
C             - ITEXP  : POINTEUR DE LA TABLE : TEXP
C
C     SORTIES :
C             - MATRES : SEGMENT OU L'ON REMPLIT ALPHAI
C
C     VARIABLES LOCALES :
C             - PARREE : PARTIE REELLE
C             - PARIMA : PARTIE IMAGINAIRE
C     POINTEURS :
C             - ITAB1 : POINTEUR DE TEXP . MAILLAGE
C             - ITAB2 : POINTEUR DE TEXP . MAILLAGE. JLIGN
C             - IPOLI1 : POINTEUR DE LISTE REELLE : PARTIE REELLE
C             - IPOLI2 : POINTEUR DE LISTE REELLE : PARTIE IMAGINAIRE
C
      CHARACTER*4 COMP(56)
      CHARACTER*8 CHARI,CHARR,MTYPR
      LOGICAL LOGII,LOGIR
      REAL*8     PARREE,PARIMA,X0,X1,X2
      INTEGER ITEXP,ITAB1,ITAB2,IPOLI1,IPOLI2
C
      SEGMENT MATRES
          COMPLEX*16 ZA1   (NP28,NP28)
          COMPLEX*16 ZSM   (NP28)
          COMPLEX*16 ZXX   (NP28)
          COMPLEX*16 ZSOL  (NNT14,NFRQ)
          REAL*8     COOR  (3 ,NP2)
          REAL*8     GAMA  (3 ,NP)
          REAL*8     CARACT(10,NP)
          REAL*8     XCL   (17 ,NNT)
          REAL*8     XCOR  (2 , 3 , NBELEM )
          REAL*8     VALDE1(2 , NBELEM , 3 )
          REAL*8     VALDE2(2 , NBELEM , 3 )
          REAL*8     VALDE3(2 , NBELEM , 1 )
          REAL*8     VALDE4(2 , NBELEM , 1 )
          INTEGER    FLAG  (NNT17)
          INTEGER    CORRES(NP2)
          INTEGER    NUMERO(NNT)
          INTEGER    MASS  (4,NNT)
          REAL*8     RMAS  (4,NNT)
          INTEGER    IRAILO(4,NNT)
          REAL*8     VALRAI(6,NNT)
          INTEGER    IPIVO(NP28)
          INTEGER    JPIVO(NP28)
          INTEGER    IAUX(NP28)
          INTEGER    IEXPER(NP)
          COMPLEX*16 ALPHAI(14,28,NP,NFRQ)
      ENDSEGMENT
C
      DATA COMP/'RUXA','RUYA','RUZA','RRXA','RRYA','RRZA',
     &         'RFXA','RFYA','RFZA','RMXA','RMYA','RMZA','RPRA','RQTA',
     &         'RUXB','RUYB','RUZB','RRXB','RRYB','RRZB',
     &         'RFXB','RFYB','RFZB','RMXB','RMYB','RMZB','RPRB','RQTB',
     &         'IUXA','IUYA','IUZA','IRXA','IRYA','IRZA',
     &         'IFXA','IFYA','IFZA','IMXA','IMYA','IMZA','IPRA','IQTA',
     &         'IUXB','IUYB','IUZB','IRXB','IRYB','IRZB',
     &         'IFXB','IFYB','IFZB','IMXB','IMYB','IMZB','IPRB','IQTB'/
C
C     INITIALISATION
C
      CHARI=' '
      CHARR=' '
C
C
      MTAB1=ITEXP
C
      SEGACT MTAB1
C
      LONTAB=MTAB1.MLOTAB
C
      DO 10 JTAB = 2,LONTAB
C
C     RECHERCHE DE LA VALEUR DU  POINTEUR TEXP . MAILLAGE : ITAB1
C
      IPT5=MTAB1.MTABII(JTAB)
      SEGACT IPT5
C
C     NOMBRE DE TUYAUX DANS LE MELEME
C
      NBEL=IPT5.NUM(/2)
C
C     NUMERO DES NOEUDS CONSTITUANT L'ELEMENT POINTE
C
      INU1=IPT5.NUM(1,NBEL)
      INU2=IPT5.NUM(2,NBEL)
C
C     RECHERCHE DU NUMERO DE L'ELEMENT EXPERIMENTAL
C
      DO 100 III=1,NP2,2
C
      IN1=MATRES.CORRES(III)
      IN2=MATRES.CORRES(III+1)
C
      IF (INU1.EQ.IN1.AND.INU2.EQ.IN2) THEN
      NUMEXP=INT(III/2) + 1
      END IF
C
      IF (INU1.EQ.IN2.AND.INU2.EQ.IN1) THEN
      NUMEXP=INT(III/2) + 1
      END IF
C
  100 CONTINUE
C
      SEGDES IPT5
C
C     1 &lt; INP &lt; NP2
C     IEXPER(INP) = 0 : TUYAU FORMULATION INTEGRALE
C     IEXPER(INP) = 1 : TUYAU FORMULATION EXPERIMENTALE
C     IEXPER(INP) EST MIS A EGAL A 1 SI UNIQUEMENT LE MOT VECT EST
C     DECODE DANS LE CHAMP DE CARACTERISTIQUES
C
      IF (IEXPER(NUMEXP).NE.0) THEN
      ITAB1=MTAB1.MTABIV(JTAB)
      END IF
C
      IF (ITAB1.NE.0) THEN
C
C     LE NOM D'UN COMPOSANT EXPERIMENTAL A ETE DETECTE
C
            DO 20 JLIGN=1,14
C
C  RECHERCHE DE LA VALEUR DU  POINTEUR TEXP . MAILLAGE . JLIGN : ITAB2
C
            CALL ACCTAB(ITAB1,'ENTIER',JLIGN,X0,CHARI,LOGII,IP0,
     &                       'TABLE',I1,X1,CHARR,LOGIR,ITAB2)
C
             IF (ITAB2.NE.0) THEN
               DO 30 JCOLO=1,28
C
C     RECHERCHE DE LA VALEUR DU  POINTEUR TEXP . JELEM . JLIGN .
C     COMP(JCOLO) : IPOLI1 -> CORRESPOND A LA PARTIE REELLE
C
               MTYPR=' '
               CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO),LOGII,IP0,
     &                            MTYPR,I1,X1,CHARR,LOGIR,IPOLI1)
               IF (MTYPR.EQ.'LISTREEL') THEN
C
C     LA PARTIE REELLE NON NULLE :
C     RECHERCHE DE LA VALEUR DU  POINTEUR TEXP . JELEM . JLIGN .
C     COMP(JCOLO+28) : IPOLI2 -> CORRESPOND A LA PARTIE IMAGINAIRE
C
                 MTYPR=' '
                 CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO+28),LOGII,IP0,
     &                              MTYPR,I1,X1,CHARR,LOGIR,IPOLI2)
                 IF (MTYPR.EQ.'LISTREEL') THEN
C
C     LA PARTIE IMAGINAIRE EST NON NULLE
C
                   MLREE4=IPOLI1
                   MLREE5=IPOLI2
                   SEGACT MLREE4
                   SEGACT MLREE5
                   DO 40 JFRQ=1,NFRQ
                   PARREE=MLREE4.PROG(JFRQ)
                   PARIMA=MLREE5.PROG(JFRQ)
C
                   MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)=CMPLX(PARREE,
     &                                                   PARIMA)
   40              CONTINUE
                   SEGDES MLREE4
                   SEGDES MLREE5
C
                 ELSE
C
                   PARIMA=0.D0
                   MLREEL=IPOLI1
                   SEGACT MLREEL
                   DO 50 JFRQ=1,NFRQ
                   PARREE=PROG(JFRQ)
C
                   MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)=
     &                              CMPLX(PARREE,PARIMA)
C
   50              CONTINUE
                   SEGDES MLREEL
C
                 END IF
               ELSE
C
C     LA PARTIE REELLE EST NULLE
C
                 PARREE=0.D0
                 MTYPR=' '
                 CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO+28),LOGII,IP0,
     &                              MTYPR,I1,X1,CHARR,LOGIR,IPOLI2)
                 IF (MTYPR.EQ.'LISTREEL') THEN
C
C     LA PARTIE IMAGINAIRE EST NON NULLE
C
                   MLREEL=IPOLI2
                   SEGACT MLREEL
                   DO 60 JFRQ=1,NFRQ
                   PARIMA=PROG(JFRQ)
C
                   MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)=
     &                              CMPLX(PARREE,PARIMA)
   60              CONTINUE
                   SEGDES MLREEL
C
                 ELSE
C
C     LA PARTIE IMAGINAIRE EST NULLE
C
                   PARIMA=0.D0
                   DO 70 JFRQ=1,NFRQ
                   MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)=
     &                                CMPLX(PARREE,PARIMA)
   70              CONTINUE
C
                 END IF
C
               END IF
C
   30          CONTINUE
C
             END IF
   20       CONTINUE
C
      END IF
   10 CONTINUE
C
      SEGDES MTAB1
C
      RETURN
C
        end