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

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