Télécharger la plaquette Cast3M


fr en

Télécharger etg.eso

Retour à la liste

Numérotation des lignes : 

etg

  1. C ETG       SOURCE    SP204843  26/02/03    21:15:19     12461          
  2.       SUBROUTINE ETG
  3.  
  4.       implicit integer (i-n)
  5.       implicit real*8(a-h,o-z)
  6.  
  7.       external long
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMTABLE
  12. -INC SMLOBJE
  13. -INC CCNOYAU
  14. -INC CCASSIS
  15. -INC CCPRECO
  16.  
  17.       LOGICAL        LOGR1,LOGR2
  18.       REAL*8         XVALRE,XVALR2
  19.       CHARACTER*(8)  TYOBJE,CHA8,CHACRE
  20.       CHARACTER*(LOCHAI) CHARRE
  21.  
  22. C     Objets geres par les TABLES 'ESCLAVE'
  23.       PARAMETER(NBOK=16)
  24.       CHARACTER*(8)  OBJOK(NBOK)
  25.       DATA OBJOK /'CHPOINT ','RIGIDITE','LOGIQUE ','MCHAML  ','MMODEL',
  26.      $           'MAILLAGE','MATRIK  ','FLOTTANT','EVOLUTIO','ENTIER',
  27.      $           'MOT'     ,'CHARGEME','LISTREEL','LISTENTI','LISTMOTS',
  28.      $           'POINT   '/
  29.  
  30. C     MACRO a synchroniser avec le DATA OBJOK pour test rapide d'entiers
  31.       MACRO,(CHPOINT ,RIGIDITE,LOGIQUE ,MCHAML  ,MMODEL,
  32.      >       MAILLAGE,MATRIK  ,FLOTTANT,EVOLUTIO,ENTIER,
  33.      >       MOT,CHARGEME,LISTREEL,LISTENTI,LISTMOTS,POINT)
  34.  
  35. C     Objets geres par les LISTOBJ
  36.       PARAMETER(NBOK2=14)
  37.       CHARACTER*(8)  OBJOK2(NBOK2)
  38.       DATA OBJOK2/'CHPOINT ','RIGIDITE','MCHAML  ','MMODEL','MAILLAGE',
  39.      $     'MATRIK  ','EVOLUTIO','ENTIER  ','CHARGEME','LISTREEL',
  40.      $     'LISTENTI','LISTMOTS','POINT   ','FLOTTANT'/
  41.  
  42. C     SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  43.       SEGMENT SID
  44. C       NBFUS  : NOMBRE D'OBJETS A FUSIONNER
  45. C       IPOINT : POINTEURS A FUSIONNER ou ENTIERS A FUSIONNER (cas particuler MAXI / MINI)
  46. C       BVAL   : LOGIQUES SUR LESQUELS ON FAIT UN ET/OU LOGIQUE
  47. C       XVAL   : REELS A FUSIONNER (cas particuler MAXI / MINI)
  48. C       CVAL   : MOTS  A FUSIONNER (cas particuler MAXI / MINI)
  49. C       CHATYP : MOT DONNANT LE TYPE   D'OBJETS A FUSIONNER
  50.         INTEGER         IPOINT(NBFUS)
  51.         LOGICAL         BVAL  (NBFUS)
  52.         REAL*8          XVAL  (NBFUS)
  53.         CHARACTER*(IC1) CVAL  (NBFUS)
  54.         CHARACTER*8     CHATYP,CREATE
  55.       ENDSEGMENT
  56.  
  57.       LOGR1 = .FALSE.
  58.       LOGR2 = .FALSE.
  59.       XVALRE= 0.D0
  60.       XVALR2= 0.D0
  61.  
  62.  
  63. CC     Lecture du premier objet
  64. CC     ------------------------
  65.       CALL MESLIR(-225)
  66.       CALL QUETYP(TYOBJE,0,IRETOU)
  67.       IF(IRETOU.EQ.0) THEN
  68. CC       Cet opérateur a encore besoin d'un opérande.
  69.          CALL ERREUR (533)
  70.          RETURN
  71.       ENDIF
  72.       CALL LIROBJ(TYOBJE,IP1,1,IRETOU)
  73.  
  74.       IF(TYOBJE.EQ.'TABLE   ') THEN
  75.          MTABLE = IP1
  76.          CALL ACCTAB(MTABLE,'MOT',0,0.D0    ,'SOUSTYPE',.TRUE.,0,
  77.      >        'MOT',IENT1,XVALRE, TYOBJE ,LOGR1 ,ID1)
  78.          IF (TYOBJE.NE.'ESCLAVE') THEN
  79. CC          Donnez une TABLE de sous-type %m1:8
  80.             MOTERR ='ESCLAVE'
  81.             CALL ERREUR(-173)
  82. CC          Le sous-type de la table est incorrect
  83.             CALL ERREUR(648)
  84.             RETURN
  85.          ENDIF
  86.  
  87.          SEGACT,MTABLE
  88.          ML=MLOTAB
  89.  
  90. C       RECHERCHE DU CREATEUR
  91.          CALL ACCTAB(MTABLE,'MOT     ',IND ,0.D0  ,'CREATEUR',.TRUE.,0
  92.      $        ,'MOT     ',IENT1,XVALR2,CHACRE  ,LOGR2 ,ID2)
  93.          IF (IERR.NE.0) RETURN
  94.          NBENT = 0
  95.          IND   = 1
  96.          TYOBJE=' '
  97.          CALL ACCTAB(MTABLE,'ENTIER',IND  ,0.D0   ,' ',.TRUE.,0 ,
  98.      &        TYOBJE ,IENT1,XVALRE ,CHARRE,LOGR1 ,ID1 )
  99.          IF (IERR.NE.0) RETURN
  100.  
  101. C       Verification que ETG traite bien ce type d'objet
  102.          CALL PLAMO8(OBJOK,NBOK,IPLAC,TYOBJE)
  103.  
  104. C       DIMENSIONNEMENT DU SEGMENT SID A (ML - 2) a cause des indices 'SOUSTYPE' et 'CREATEUR'
  105.          NBFUS = ML - 2
  106.          IF(IPLAC .EQ. MOT)THEN
  107.             IC1 = LONG(CHARRE)
  108.          ELSE
  109.             IC1 = 0
  110.          ENDIF
  111.          SEGINI,SID
  112.          SID.CREATE=CHACRE
  113.  
  114.          IF(IPLAC .EQ. MMODEL)THEN
  115. C         Verification si le MMODEL partitionne est deja dans le CCPRECO (resultat instantanné)
  116.             DO IIMOD = 1, NMOPAR
  117.                IF (PESCLA(IIMOD) .EQ. 0) THEN
  118. C             On sort
  119.                   GOTO 1
  120.                ELSEIF (MTABLE .EQ. PESCLA(IIMOD)) THEN
  121.                   imodel = PARMOD(IIMOD)
  122.                   CALL ACTOBJ('MMODEL',imodel,1)
  123.                   CALL ECROBJ('MMODEL',imodel)
  124.                   SEGSUP,SID
  125.                   SEGDES,MTABLE
  126.                   RETURN
  127.                ENDIF
  128.             ENDDO
  129.          ENDIF
  130.  1       CONTINUE
  131.  
  132.          IF (IPLAC .GT. 0) THEN
  133. C         REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  134.             NBENT            = NBENT + 1
  135.             IF(IPLAC .EQ. ENTIER)THEN
  136.                SID.IPOINT(NBENT)= IENT1
  137.             ELSE
  138.                SID.IPOINT(NBENT)= ID1
  139.             ENDIF
  140.             SID.BVAL  (NBENT)= LOGR1
  141.             SID.XVAL  (NBENT)= XVALRE
  142.             IF(IPLAC .EQ. MOT)THEN
  143.                SID.CVAL(NBENT)= CHARRE
  144.             ENDIF
  145.             SID.CHATYP       = TYOBJE
  146.             CHA8             = TYOBJE
  147.  
  148.             IF (NBFUS .GE. 2) THEN
  149.                DO I=2,NBFUS
  150.                   IND = I
  151.                   CALL ACCTAB(MTABLE,'ENTIER  ',IND,0.D0,' ',.TRUE.,0,
  152.      &                 TYOBJE,IENT2,XVALRE,CHARRE,LOGR2,ID2)
  153.                   IF (IERR.NE.0) RETURN
  154.                   IF (TYOBJE .NE. CHA8) THEN
  155. C                   ERREUR SI LES TYPES SONT DIFFERENTS ENTRE 2 INDICES DE LA TABLE ESCLAVE
  156.                     MOTERR       = CHA8
  157.                     MOTERR(9:16) = TYOBJE
  158.                     CALL ERREUR(1045)
  159.                     SEGSUP,SID
  160.                     RETURN
  161.                   ENDIF
  162.  
  163. C                 REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  164.                   NBENT=NBENT + 1
  165.                   IF(IPLAC .EQ. ENTIER)THEN
  166.                      SID.IPOINT(NBENT)= IENT2
  167.                   ELSE
  168.                      SID.IPOINT(NBENT)= ID2
  169.                   ENDIF
  170.                   SID.BVAL  (NBENT)= LOGR2
  171.                   SID.XVAL  (NBENT)= XVALRE
  172.                   IF(IPLAC .EQ. MOT)THEN
  173.                      IF(LONG(CHARRE) .GT. IC1)THEN
  174.                         IC1 = LONG(CHARRE)
  175.                         SEGADJ,SID
  176.                      ENDIF
  177.                      SID.CVAL(NBENT)= CHARRE
  178.                   ENDIF
  179.                ENDDO
  180.             ENDIF
  181.  
  182. C           LANCEMENT DE LA FUSION DES OBJETS
  183. C           WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS ETG    : ',CHA8
  184.             ID = SID
  185.             CALL FUNOBJ(ID,ID1,XVALRE,LOGR1)
  186.             IF(IERR .NE. 0) RETURN
  187.  
  188.          ELSE
  189. C           Type d'objet non traite par ETG
  190.             MOTERR = TYOBJE
  191.             CALL ERREUR(1046)
  192.             RETURN
  193.          ENDIF
  194.  
  195.       ELSEIF(TYOBJE.EQ.'LISTOBJE') THEN
  196.          MLOBJE = IP1
  197.          SEGACT,MLOBJE
  198.          TYOBJE = MLOBJE.TYPOBJ
  199.          IF (TYPOBJ.EQ.'FLOTTANT') THEN
  200.            ML     = MLOBJE.RLIREE(/1)
  201.          ELSE
  202.            ML     = MLOBJE.LISOBJ(/1)
  203.          ENDIF
  204.          CHACRE =' '
  205.  
  206. C        Verification que ETG traite bien ce type d'objet
  207.          CALL PLAMO8(OBJOK2,NBOK2,IPLAC2,TYOBJE)
  208.  
  209. C        On trouve IPLAC dans OBJOK pour le "CASE, IPLAC"
  210.          CALL PLAMO8(OBJOK ,NBOK ,IPLAC ,TYOBJE)
  211.  
  212.          IF (IPLAC .EQ. MOT) THEN
  213.             IC1 = LONG(CHARRE)
  214.          ELSE
  215.             IC1 = 0
  216.          ENDIF
  217.          NBFUS = ML
  218.          SEGINI,SID
  219.          SID.CREATE= CHACRE
  220.          SID.CHATYP= TYOBJE
  221.          IF (IPLAC2 .GT. 0) THEN
  222. C         REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  223.             DO I=1,ML
  224.                SID.IPOINT(I)=LISOBJ(I)
  225.             ENDDO
  226. C           LANCEMENT DE LA FUSION DES OBJETS
  227. C           WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS ETG    : ',TYOBJE
  228.             ID = SID
  229.             CALL FUNOBJ(ID,ID1,XVALRE,LOGR1)
  230.             IF(IERR .NE. 0) RETURN
  231.  
  232.          ELSE
  233.             MOTERR = TYOBJE
  234.             CALL ERREUR(1046)
  235.             RETURN
  236.          ENDIF
  237.  
  238.       ELSE
  239.         CALL REFUS
  240.         RETURN
  241.       ENDIF
  242.  
  243. C     Ecriture du resultat dans la pile
  244. C     write(ioimp,*) 'iplac,tyobje=',iplac,tyobje
  245.       CASE, IPLAC
  246.           WHEN, LOGIQUE
  247.             CALL ECRLOG(LOGR1)
  248.           WHEN, MOT
  249.             CALL ACTOBJ('LISTMOTS',ID1,1)
  250.             CALL ECROBJ('LISTMOTS',ID1)
  251.           WHEN, ENTIER
  252. C           Il manque la gestion de MAXI et MINI pour ce cas la !
  253.             CALL ACTOBJ('LISTENTI',ID1,1)
  254.             CALL ECROBJ('LISTENTI',ID1)
  255.           WHEN, FLOTTANT
  256.             IF(ID1 .EQ. 0)THEN
  257.               CALL ECRREE(XVALRE)
  258.             ELSE
  259.               CALL ACTOBJ('LISTREEL',ID1,1)
  260.               CALL ECROBJ('LISTREEL',ID1)
  261.             ENDIF
  262.           WHEN, POINT
  263.               CALL ACTOBJ('MAILLAGE',ID1,1)
  264.               CALL ECROBJ('MAILLAGE',ID1)
  265.           WHENOTHERS
  266. C           Cas des POINTEURS sur des OBJETS
  267.             CALL ACTOBJ(TYOBJE,ID1,1)
  268.             CALL ECROBJ(TYOBJE,ID1)
  269.       ENDCASE
  270.  
  271.       SEGSUP,SID
  272.       IF(TYOBJE.EQ.'TABLE   ') THEN
  273.          SEGDES,MTABLE
  274.       ELSEIF(TYOBJE.EQ.'LISTOBJE') THEN
  275.          SEGACT,MLOBJE
  276.       ENDIF
  277.  
  278.       RETURN
  279.       END
  280.  
  281.  
  282.  
  283.  

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