Télécharger la plaquette Cast3M


fr en

Télécharger extr20.eso

Retour à la liste

Numérotation des lignes : 

extr20

  1. C EXTR20    SOURCE    PASCAL    22/06/29    21:15:02     11396          
  2.  
  3.       SUBROUTINE EXTR20 (IPCHAR,CMOT,ICHGT,LCHGT,IEC,
  4.      &                   IPRES1,CTYP1,IPRES2,CTYP2)
  5.  
  6. C=======================================================================
  7. C
  8. C     RESULTAT = EXTRAIRE CHARGEME ... ;
  9. C
  10. C  1)    CHARGEME   'CHAR'  (ENTIER)     CHARGEME
  11. C  2)    CHARGEME   'CHAM'  (ENTIER)     CHPOINT ou MCHAML
  12. C  3)    CHARGEME   'TRAJ'  (ENTIER)     CHPOINT
  13. C  4)    CHARGEME   'EVOL'  (ENTIER)     EVOLUTION
  14. C  5)    CHARGEME   'VITE'  (ENTIER)     EVOLUTION
  15. C  6)    CHARGEME   'COMP'               LISTMOTS
  16. C  7)    CHARGEME   'LIE '               CHARGEME
  17. C  8)    CHARGEME   'LIBR'               CHARGEME
  18. C  9)    CHARGEME    MOT   'TABLES'      TABLES
  19. C  10)   CHARGEME    MOT                 CHARGEME
  20. C  11)   CHARGEME    LISTMOTS            CHARGEME
  21. C
  22. C=======================================================================
  23.  
  24.       IMPLICIT INTEGER(I-N)
  25.       IMPLICIT REAL*8(A-H,O-Z)
  26.  
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCGEOME
  31.  
  32. -INC SMCHARG
  33. -INC SMEVOLL
  34. -INC SMLMOTS
  35.  
  36.       CHARACTER*(*) CMOT
  37.       CHARACTER*(8) CTYP1,CTYP2
  38.  
  39.       CHARACTER*(4) MCOMP
  40.  
  41.       MCOMP  = CMOT
  42.       IPRES1 = 0
  43.       CTYP1  = '        '
  44.       IPRES2 = 0
  45.       CTYP2  = '        '
  46.  
  47.       MCHARG = IPCHAR
  48.       SEGACT,MCHARG
  49.       NCHAR = KCHARG(/1)
  50. C
  51.       IF (NCHAR.LT.IEC) THEN
  52.         INTERR(1) = IEC
  53.         CALL ERREUR(690)
  54.         GOTO 9999
  55.       ENDIF
  56. C
  57.       ICHG2 = ICHGT + 2
  58.       GOTO (1010, 1000, 10, 20, 30, 40, 50, 60, 70, 70, 90, 100), ICHG2
  59.       GOTO 9999
  60. C
  61. C MOT-CLE 'CHAR' ==> ICHGT = 1
  62. C----------------
  63.  10   CONTINUE
  64.       N = 1
  65.       SEGINI,MCHAR1
  66.       MCHAR1.KCHARG(1) = KCHARG(IEC)
  67.       MCHAR1.CHANOM(1) = CHANOM(IEC)
  68.       MCHAR1.CHANAT(1) = CHANAT(IEC)
  69.       MCHAR1.CHAMOB(1) = CHAMOB(IEC)
  70.       MCHAR1.CHALIE(1) = CHALIE(IEC)
  71.       SEGDES,MCHAR1
  72.       IPRES1 = MCHAR1
  73.       CTYP1  = 'CHARGEME'
  74.       GOTO 9999
  75. C
  76. C MOT-CLE 'CHAM' ==> ICHGT = 2
  77. C----------------
  78.  20   CONTINUE
  79.       ICHARG = KCHARG(IEC)
  80.       SEGACT,ICHARG
  81.       IF (CHATYP.EQ.'CHPOINT ' .OR. CHATYP.EQ.'MCHAML  ') THEN
  82.         IPRES1 = ICHPO1
  83.         CTYP1  = CHATYP
  84.       ELSE
  85.         INTERR(1) = IEC
  86.         CALL ERREUR(688)
  87.       ENDIF
  88.       SEGDES,ICHARG
  89.       GOTO 9999
  90. C
  91. C MOT-CLE 'TRAJ' ==> ICHGT = 3
  92. C---------------
  93.  30   CONTINUE
  94.       IF (CHAMOB(IEC).EQ.'TRAJ') THEN
  95.         ICHARG = KCHARG(IEC)
  96.         SEGACT,ICHARG
  97.         IPRES1 = ICHPO4
  98.         CTYP1  = 'CHPOINT'
  99.         SEGDES,ICHARG
  100.       ELSE
  101.         GOTO 1000
  102. C       INTERR(1) = IEC
  103. C       CALL ERREUR(900)
  104.       ENDIF
  105.       GOTO 9999
  106. C
  107. C MOT-CLE 'EVOL' ==> ICHGT = 4
  108. C---------------
  109.  40   CONTINUE
  110.       ICHARG = KCHARG(IEC)
  111.       SEGACT,ICHARG
  112.       IF (CHATYP.EQ.'CHPOINT ' .OR. CHATYP.EQ.'MCHAML  ') THEN
  113.         SEGINI,KEVOLL
  114.         NUMEVX = IDCOUL
  115.         NUMEVY = 'REEL'
  116.         TYPX = 'LISTREEL'
  117.         TYPY = 'LISTREEL'
  118.         NOMEVX = 'TEMPS'
  119.         NOMEVY = CHANOM(IEC)
  120.         IPROGX = ICHPO2
  121.         IPROGY = ICHPO3
  122.         KEVTEX = 'Evolution temporelle de '//CHANOM(IEC)
  123.         SEGDES,KEVOLL
  124.         N = 1
  125.         SEGINI,MEVOLL
  126.         ITYEVO = 'REEL'
  127.         IEVTEX = 'Evolution extraite d''un CHARGEMENT'
  128.         IEVOLL(1) = KEVOLL
  129.         SEGDES,MEVOLL
  130.         IPRES1 = MEVOLL
  131.         CTYP1  = 'EVOLUTIO'
  132.       ELSE
  133.         INTERR(1) = IEC
  134.         CALL ERREUR(689)
  135.       ENDIF
  136.       SEGDES,ICHARG
  137.       GOTO 9999
  138. C
  139. C MOT-CLE 'VITE' ==> ICHGT = 5
  140. C---------------
  141.  50   CONTINUE
  142.       IF (CHAMOB(IEC).EQ.'TRAN' .OR. CHAMOB(IEC).EQ.'ROTA') THEN
  143.         ICHARG = KCHARG(IEC)
  144.         SEGACT,ICHARG
  145.         SEGINI,KEVOLL
  146.         NUMEVX = IDCOUL
  147.         NUMEVY = 'REEL'
  148.         TYPX = 'LISTREEL'
  149.         TYPY = 'LISTREEL'
  150.         IPROGX = ICHPO6
  151.         IPROGY = ICHPO7
  152.         NOMEVX = 'TEMPS'
  153.         NOMEVY = CHANOM(IEC)
  154.         KEVTEX='Evolution temporelle de '//CHANOM(IEC)
  155.         SEGDES,KEVOLL
  156.         SEGDES,ICHARG
  157.         N = 1
  158.         SEGINI,MEVOLL
  159.         ITYEVO = 'REEL'
  160.         IEVTEX = 'Evolution extraite d''un CHARGEMENT'
  161.         IEVOLL(1) = KEVOLL
  162.         SEGDES,MEVOLL
  163.         IPRES1 = MEVOLL
  164.         CTYP1  = 'EVOLUTIO'
  165.       ELSE
  166.         INTERR(1) = IEC
  167.         CALL ERREUR(901)
  168.       ENDIF
  169.       GOTO 9999
  170.  
  171. C MOT-CLE 'COMP' ==> ICHGT = 6
  172. C----------------
  173.  60   CONTINUE
  174.       JGN = 4
  175.       JGM = NCHAR
  176.       SEGINI,MLMOTS
  177.       MOTS(1) = CHANOM(1)
  178.       NMO1 = 1
  179.       DO icha = 2, NCHAR
  180.         DO kcha = 1, NMO1
  181.           IF (CHANOM(icha).EQ.MOTS(kcha)) GOTO 61
  182.         ENDDO
  183.         NMO1 = NMO1 + 1
  184.         MOTS(NMO1) = CHANOM(icha)
  185.  61     CONTINUE
  186.       ENDDO
  187.       IF (JGM.NE.NMO1) THEN
  188.         JGM = NMO1
  189.         SEGADJ,MLMOTS
  190.       ENDIF
  191.       SEGDES,MLMOTS
  192.       IPRES1 = MLMOTS
  193.       CTYP1  = 'LISTMOTS'
  194.       GOTO 9999
  195. C
  196. C MOT-CLE 'LIE ' OU 'LIBR' ==> ICHGT = 7 ou 8
  197. C--------------------------
  198.  70   CONTINUE
  199.       N = NCHAR
  200.       SEGINI,MCHAR1
  201.       kcha = 0
  202.       DO icha = 1, NCHAR
  203.         IF (CHALIE(icha).EQ.CMOT) then
  204.           kcha = kcha + 1
  205.           MCHAR1.KCHARG(kcha) = KCHARG(icha)
  206.           MCHAR1.CHANAT(kcha) = CHANAT(icha)
  207.           MCHAR1.CHANOM(kcha) = CHANOM(icha)
  208.           MCHAR1.CHAMOB(kcha) = CHAMOB(icha)
  209.           MCHAR1.CHALIE(kcha) = CHALIE(icha)
  210.         ENDIF
  211.       ENDDO
  212.       IF (kcha.LE.0) THEN
  213.         SEGSUP,MCHAR1
  214.         MOTERR = CMOT
  215.         CALL ERREUR(899)
  216.       ELSE
  217.         IF (kcha.NE.N) THEN
  218.           N = kcha
  219.           SEGADJ,MCHAR1
  220.         ENDIF
  221.         SEGDES,MCHAR1
  222.         IPRES1 = MCHAR1
  223.         CTYP1  = 'CHARGEME'
  224.       ENDIF
  225.       GOTO 9999
  226.  
  227. C
  228. C MOT-CLE 'LOBJ' ==> ICHGT = 9
  229. C--------------------------
  230.  90   CONTINUE
  231.       ICHARG = KCHARG(IEC)
  232.       SEGACT,ICHARG
  233.       IF (CHATYP.EQ.'LISTOBJE') THEN
  234.         IPRES1 = ICHPO1
  235.         CTYP1  = 'LISTOBJE'
  236.       ELSE
  237.         INTERR(1) = IEC
  238.         CALL ERREUR(1137)
  239.       ENDIF
  240.       SEGDES,ICHARG
  241.       GOTO 9999
  242. C
  243. C MOT-CLE 'LREE' ==> ICHGT = 10
  244. C--------------------------
  245.  100  CONTINUE
  246.       ICHARG = KCHARG(IEC)
  247.       SEGACT,ICHARG
  248.       IF (CHATYP.EQ.'LISTOBJE') THEN
  249.         IPRES1 = ICHPO2
  250.         CTYP1  = 'LISTREEL'
  251.       ELSE
  252.         INTERR(1) = IEC
  253.         CALL ERREUR(1137)
  254.       ENDIF
  255.       SEGDES,ICHARG
  256.       GOTO 9999
  257.  
  258. C COMPOSANTE MOT ou LISTMOTS ==> ICHGT = 0
  259. C----------------------------
  260.  1000 CONTINUE
  261.       N = NCHAR
  262.       SEGINI,MCHAR1
  263.       NCOMP = 1
  264.       MLMOTS = LCHGT
  265.       IF (LCHGT.GT.0) THEN
  266.         SEGACT,MLMOTS
  267.         NCOMP = MLMOTS.MOTS(/2)
  268.       ENDIF
  269.  
  270.       kcha = 0
  271.       DO icomp = 1, NCOMP
  272.         IF (LCHGT.GT.0) MCOMP = MLMOTS.MOTS(icomp)
  273.         kcha1 = 0
  274.         DO icha = 1, NCHAR
  275.           IF (CHANOM(icha).EQ.MCOMP) THEN
  276.             kcha = kcha + 1
  277.             MCHAR1.KCHARG(kcha) = KCHARG(icha)
  278.             MCHAR1.CHANAT(kcha) = CHANAT(icha)
  279.             MCHAR1.CHANOM(kcha) = CHANOM(icha)
  280.             MCHAR1.CHAMOB(kcha) = CHAMOB(icha)
  281.             MCHAR1.CHALIE(kcha) = CHALIE(icha)
  282.             kcha1 = 1
  283.           ENDIF
  284.         ENDDO
  285.         IF (kcha1.EQ.0) THEN
  286.           MOTERR(1:4) = MCOMP
  287.           CALL ERREUR(685)
  288.         ENDIF
  289.       ENDDO
  290.       IF (LCHGT.GT.0) SEGDES,MLMOTS
  291.  
  292.       IF (IERR.EQ.0) THEN
  293.         IF (kcha.NE.N) THEN
  294.           N = kcha
  295.           SEGADJ,MCHAR1
  296.         ENDIF
  297.         SEGDES,MCHAR1
  298.         IPRES1 = MCHAR1
  299.         CTYP1  = 'CHARGEME'
  300.       ELSE
  301.         SEGSUP,MCHAR1
  302.       ENDIF
  303.       GOTO 9999
  304.  
  305. C TABLES DE CHARGEMENT DE LA COMPOSANTE MCOMP ==> ICHGT = -1
  306. C--------------------------------------------
  307.  1010 CONTINUE
  308.       kcha = 0
  309.       DO icha = 1, NCHAR
  310.         IF (CHANOM(icha).EQ.MCOMP) THEN
  311.           kcha = kcha + 1
  312.           ICHARG = KCHARG(icha)
  313.         ENDIF
  314.       ENDDO
  315.       IF (kcha.NE.1) THEN
  316.         IF (kcha.EQ.0) THEN
  317.           MOTERR = MCOMP
  318.           CALL ERREUR(685)
  319.         ELSE
  320.           CALL ERREUR(697)
  321.           CALL ERREUR(512)
  322.         ENDIF
  323.       ELSE
  324.         SEGACT,ICHARG
  325.         IF (CHATYP(1:8).NE.'TABLE   ') THEN
  326.           CALL ERREUR(697)
  327.           GOTO 9999
  328.         ENDIF
  329.         IPRES1 = ICHPO2
  330.         CTYP1  = 'TABLE   '
  331.         IPRES2 = ICHPO1
  332.         CTYP2  = 'TABLE   '
  333.         SEGDES,ICHARG
  334. * Mettre une verification sur le type de ichpo1 et ichpo2 : TABLE ?
  335.       ENDIF
  336.       GOTO 9999
  337.  
  338.  9999 CONTINUE
  339.       SEGDES,MCHARG
  340.  
  341.       RETURN
  342.       END
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  

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