Télécharger evsolu.eso

Retour à la liste

evsolu
C EVSOLU    SOURCE    BP208322  22/09/09    21:15:05     11448          
      SUBROUTINE EVSOLU(ICOUL)
C=======================================================================
C   OPTION SOLU DE L'OPERATEUR EVOL (CONSTRUCTION DE COURBES)
C
C.1.EVOLUTION D'UN DDL DANS L'OBJET SOLUTION:
C       MEVOL = EVOL COUL SOLU MSOLUT TYPE  PT1 COMP (INSTANTS) ;
C               ----      ----        ----      ----
C
C.2.EVOLUTION DE PLUSIEURS DDL DANS L'OBJET SOLUTION:
C       MEVOL = EVOL COUL SOLU MSOLUT TYPE CHP1      (INSTANTS) ;
C               ----      ----        ----
C
C.3.EVOLUTION DE LA CONTRIBUTION MODALE RELATIVE AU MODE MOD1:
C       MEVOL = EVOL COUL SOLU MSOLUT TYPE  MOD1 ALFA (INSTANTS);
C               ----      ----        ----       ----
C
C.4.EVOLUTION D'UNE VARIABLE DE LIAISON RELATIVE A LA LIAISON MAT1:
C       MEVOL = EVOL COUL SOLU MSOLUT LIAI  MAT1 COMP (INSTANTS) ;
C               ----      ----        ----       ----
C
C.5.EVOLUTION D'UNE INCONNUE DE LIAISON RELATIVE A LA LIAISON MAT1:
C       MEVOL = EVOL COUL SOLU MSOLUT TYPE  MAT1 COMP (INSTANTS);
C               ----      ----        ----       ----
C
C         COUL   : COULEUR (FACULTATIVE)
C         MEVOL  : OBJET DE TYPE EVOLUTION
C         MSOLUT : OBJET SOLUTION
C         TYPE   : MOT CLE:TYPE DE LA VARIABLE (DEPL,VITE,ACCE,LIAI..)
C         COMP   : NOM DE LA COMPOSANTE CHOISIE
C        INSTANTS: PROCEDURE FACULTATIVE POUR CHOISIR LES CAS DE SORTIE
C              PROGX :OBJET LISTREEL, LISTE DES TEMPS A SORTIR
C              LECTC :OBJET LISTENTI, LISTE DES CAS A SORTIR
C              RIEN  :L'OBJET EVOLUTION PORTE SUR TOUS LES CAS PRESENTS
C                     DANS LE MSOLUT
C
C         PT1    : POINT OU MELEME A EXTRAIRE
C         CHP1   : CHPOINT CONTENANT LES POINTS ET DDL (FABRIQUE PAR
C                  EXEMPLE PAR MANU CHPO )
C         MOD1   : OBJET MSOLUT (MODE OU SOLUSTAT...)
C         MAT1   : OBJET ATTACHE.
C
C         LES OBJETS PT1,MOD1,MAT1 SERVENT A REPERER DANS LES CHAMPS
C         CHOISIS, LE(S) POINT(S) QUI INTERESSENT L'EVOLUTION.
C
C   CREATION    : 16/10/85, FARVACQUE
C   MODIFS      : 2015, bp ajout du titre de la LEGEnde
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
       LOGICAL L0,L1
       REAL*8 X0,X1
       CHARACTER*4 CHAR0,CHAR1
       CHARACTER*8 CTYP
-INC PPARAM
-INC CCOPTIO
-INC SMSOLUT
-INC SMTABLE
-INC SMEVOLL
-INC SMATTAC
-INC SMELEME
-INC SMCHPOI
      SEGMENT NUMOO
       INTEGER NUMO(N),KLIST(N)
       CHARACTER*(LOCHPO) NUDDL(N)
      ENDSEGMENT
      CHARACTER*72 TI,MTIT1
*     CHARACTER*4 MCHA,NOMCO
      CHARACTER*72 MCHA,NOMCO
      CHARACTER*8 ITYPE
      CHARACTER*8 ITYP1
      CHARACTER*4 MOTIT1(1)
      DATA MOTIT1/'LEGE'/
 
C  LECTURE OPTIONNELLE DU TITRE DE LA SOUS EVOLUTION DE LA COURBE (LEGE) :
      MTIT1=' '
      ITIT1=0
      CALL LIRMOT(MOTIT1,1,ITIT1,0)
      IF(ITIT1.EQ.1) THEN
         CALL LIRCHA(MTIT1,1,IRETOU)
         IF(IERR.NE.0) RETURN
      ENDIF
 
C------TYPE DU PROCHAIN OBJET A LIRE----(TABLE OU SOLUTION)
      CALL QUETYP (CTYP,1,IRETOU)
      IF (IERR.NE.0) RETURN
 
C ---  ON LIT LE NOM DU CHAMP A TRAITER ET LE NOM DE LA COMPOSANTE
      CALL LIRCHA(MCHA,1,IRETOU)
      IF(IERR.NE.0) GOTO 5000
       LCHALU=IRETOU
      CALL LIRCHA(NOMCO,0,IRETOU)
      IF(IRETOU.EQ.0) NOMCO=' '
      LCOLU=IRETOU
C
      IF  (CTYP(1:5).EQ.'TABLE') THEN
        ISTA=0
        CALL LIRTAB ('RESULTAT_DYNE',ISTA,1,IRETOU)
        IF (IERR.NE.0) GOTO 5000
      ENDIF
C--------------
C
      IF  (CTYP(1:8).EQ.'SOLUTION') THEN
        CALL LIROBJ('SOLUTION',KSOLU,1,IRETOU)
        IF(IERR.NE.0) GOTO 5000
        MSOLUT=KSOLU
      ENDIF
C-----ON LIT EVENTUELLEMENT LA LISTE DES PAS DE TEMPS OU DE CAS ---
      IPX=0
      ITOUS=0
      ILX=0
      CALL LIROBJ('LISTREEL',IPX,0,IRETOU)
      IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU)
      IF(IRETOU.EQ.0) ITOUS=1
C----------------------------------------------------------
C *** ON VA CHERCHER LE CHAMP  MCHA  DANS LE MSOLUT
C
      IF  (CTYP(1:8).EQ.'SOLUTION') THEN
        SEGACT MSOLUT
        MOTERR(1:8)= ITYSOL
        CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT)
        IF(ICHA.EQ.0) THEN
           MOTERR(1:8)='SOLUTION'
           MOTERR(9:26)=ITYSOL
           MOTERR(30:38)=MCHA
           CALL ERREUR(235)
C          ERREUR DANS LE TYPE DE CHAMP
           GOTO 5000
        ENDIF
        MSOLEN=MSOLIS(ICHA)
        IF(MSOLEN.EQ.0) THEN
           MOTERR(1:8)='SOLUTION'
           MOTERR(9:26)=ITYSOL
           MOTERR(30:38)=MCHA
           CALL ERREUR(235)
C          CE TYPE DE CHAMP EST VIDE DANS LE MSOLUT
           GOTO 5000
        ENDIF
C
C  **** VERIFS DE COMPATIBILITE IPX,ILX, MSOLUT... EN RETOUR :
C  **** DANS IPX LE LISTREEL A METTRE DANS IPROGX
C  **** DANS ILEX LE LISTENTI QUI CONTIENT LES NUMERO DES CHAMPS
C
      IF(MSOLIS(1).EQ.0)GOTO 600
      IBOS=MSOLUT
      CALL VERIDY(IBOS,IPX,ICHA,ITOUS,ILEX,ITYP1)
      MSOLUT=IBOS
      SEGACT MSOLUT
      IF(IERR.NE.0) GOTO 5000
      GOTO 700
 600  CONTINUE
      IF(MSOLIS(3).EQ.0) GOTO601
      IBOS=MSOLUT
      CALL VERIMO(IBOS,ILX,ICHA,ITOUS,ILEX,IPX,ITYP1)
      IF(IERR.NE.0) GOTO 5000
      MSOLUT=IBOS
      SEGACT MSOLUT
      GOTO 700
 601  CONTINUE
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:16)=ITYSOL
      CALL ERREUR(131)
C  NON DISPONIBLE
      GOTO 5000
C
 700  IF( MSOLIT(ICHA).NE.2) GOTO 1002
      SEGDES MSOLUT
      ENDIF
C--------------------------------------------
C---CAS D UN OBJET DE TYPE TABLE ------------
      IF (CTYP(1:5).EQ.'TABLE') THEN
      ICHA =0
      MTAB1=ISTA
      LBO=0
      I0=1
      IRET1=0
C --- ON PREND LA PREMIERE TABLE (PAS DE TEMPS 1)
      CALL ACCTAB (ISTA ,'ENTIER',I0,X0,CHAR0,L0,IRET0,
     1                    'TABLE',I1,X1,CHAR1,L1,IRET1)
       IBOBO=IRET1
      CALL CHTCHA (MCHA,LCHALU,IBOBO,ICHA )
        IF(ICHA.EQ.0) THEN
           MOTERR(1:8)='TABLE'
           MOTERR(9:26)=MCHA(1:8)
           MOTERR(30:38)=MCHA
           CALL ERREUR(235)
C          ERREUR DANS LE TYPE DE CHAMP
           GOTO 5000
        ENDIF
C  **** VERIFS DE COMPATIBILITE IPX,ILX, MTABLE... EN RETOUR :
C  **** DANS IPX LE LISTREEL A METTRE DANS IPROGX
C  **** DANS ILEX LE LISTENTI QUI CONTIENT LES NUMERO DES CHAMPS
      CALL VERITA(ISTA,IPX,ICHA,ITOUS,ILEX,ITYP1)
      IF(IERR.NE.0) GOTO 5000
      ENDIF
C **** LA SORTIE PORTE SUR DES CHPOINTS. ON FABRIQUE NUMOO LE TABLEAU
C ***  DE SORTIE: LECTURE D'UN POINT OU D'UN MATTAC OU D'UN MODE OU
C **** D'UN CHPOINT OU D'UN MELEME
C
      CALL LIROBJ('POINT   ',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
        ITYPE='POINT'
        GOTO 10
      ENDIF
      CALL LIROBJ('MAILLAGE',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
         ITYPE='MAILLAGE'
         GOTO 10
      ENDIF
      CALL LIROBJ('CHPOINT ',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
         ITYPE='CHPOINT'
         GOTO 10
      ENDIF
      CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
         ITYPE='ATTACHE'
         GOTO 10
      ENDIF
      CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
         ITYPE='SOLUTION'
         GOTO 10
       ENDIF
      CALL LIRTAB('BASE_MODALE',IRET,0,IRETOU)
      IF(IRETOU.NE.0) THEN
         ITYPE='TABLE   '
         GOTO 10
       ENDIF
C
         CALL ERREUR(248)
C        ON NE TROUVE PAS LE SUPPORT QUI CONTIENT LES POINTS
         GOTO 5000
C
  10  CONTINUE
      CALL EVNUMO(ITYPE,IRET,NOMCO,IBOO)
      IF(IERR.NE.0) GOTO 5000
C
C *** FABRICATION DU( OU DES) PROG CORRESPONDANT AU TABLEAU NUMOO
C *** ET AUX INSTANTS ILEX (ILEX EST TUE DANS EVOL1)
C
      CALL EVOL1(IBOO,ILEX)
      NUMOO=IBOO
      IF(IERR.NE.0) GOTO 5000
      GOTO 3000
C
C *** LA SORTIE PORTE SUR DES CHAMELEM
C
 1002 CONTINUE
C     OPTION NON DISPONIBLE
      CALL ERREUR(19)
      GOTO 5000
C
 3000 CONTINUE
C
C  *** INITIALISATION DE MEVOLL
C
      N=NUMO(/1)
      SEGINI MEVOLL
      ITYEVO='REEL'
      TI(1:72)=TITREE
      IEVTEX=TI
      DO 2080 I=1,NUMO(/1)
      SEGINI KEVOLL
      TYPX='LISTREEL'
      TYPY='LISTREEL'
      IPROGX=IPX
      IPROGY=KLIST(I)
      NOMEVX=ITYP1
      NOMEVY(1:4)=MCHA
      WRITE(NOMEVY(5:8),FMT='(I4)') NUMO(I)
      NOMEVY(9:12)=NUDDL(I)
c       KEVTEX=TI
      IF(ITIT1.EQ.0) MTIT1(1:12)=NOMEVY(1:12)
      KEVTEX=MTIT1
      NUMEVX=ICOUL
      NUMEVY='REEL'
      SEGDES KEVOLL
      IEVOLL(I)=KEVOLL
 2080 CONTINUE
      SEGDES MEVOLL
      SEGSUP NUMOO
      CALL ECROBJ('EVOLUTIO',MEVOLL)
 5000 CONTINUE
      RETURN
      END
 
 
 
 
 
 
 

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