Télécharger la plaquette Cast3M


fr en

Télécharger evol2.eso

Retour à la liste

Numérotation des lignes : 

evol2

  1. C EVOL2     SOURCE    BP208322  22/09/09    21:15:03     11448          
  2.       SUBROUTINE EVOL2(IBOO,ILEX,IBOBAS,ICHAN)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C=======================================================================
  6. C ILEX CONTIENT LA SUITE DES CHPOINTS DES CONTRIBUTIONS MODALES.
  7. C POUR LES COUPLES POINTS-COMPOSANTES CONTENUS DANS NUMOO, ON
  8. C RECOMBINE LES MODES ET SOLUTIONS STATIQUES CONTENUS DANS MSOBAS .
  9. C RESULTAT DANS LE(S) LISTREEL KLIST.
  10. C APPELE PAR EVRECO
  11. C SI ICHAN=0 ON TRAVAILLE SUR UN CHPOINT
  12. C SI ICHAN=1 ON TRAVAILLE SUR UN CHAMELEM ET ON LE TRANSFORME EN
  13. C            CHPOINT PAR UN APPEL A PELPO
  14. C APPELLE : ERREUR(61,243,18) IANUL PROSC1
  15. C CREATION    : 02/04/85
  16. C PROGRAMMEUR : FARVACQUE
  17. C=======================================================================
  18. C
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMBASEM
  23. -INC SMCHPOI
  24. -INC SMSOLUT
  25. -INC SMLREEL
  26. -INC SMELEME
  27. -INC SMCOORD
  28.       SEGMENT ICPR(nbpts)
  29.       SEGMENT ICPR1(nbpts)
  30.       SEGMENT/ITRAV1/( TRAV(LDEPL,N)*D)
  31.       SEGMENT/ITRAV2/(TRAVV(LDEPL)*D)
  32.       SEGMENT/ITRAV3/(ICC(N),ISS(N),IPP(N),NBB(N))
  33.       SEGMENT IPOS(NSOUP1)
  34.       SEGMENT ITRAV(2,LDEPL)
  35.       SEGMENT NUMOO
  36.        INTEGER NUMO(N),KLIST(N)
  37.        CHARACTER*(LOCHPO) NUDDL(N)
  38.       ENDSEGMENT
  39.       DIMENSION KDEPL(2),IMEL(2)
  40.       CHARACTER*(LOCOMP) NUJ
  41. C
  42.       NUMOO=IBOO
  43.       SEGACT NUMOO
  44.       N=NUMO(/1)
  45.       MSOBAS=IBOBAS
  46.       SEGACT MSOBAS
  47.       LDEPL=0
  48.       DO 6 ICAS=1,2
  49.       KDEPL(ICAS)=0
  50.       MSOLUT=IBSTRM(ICAS+1)
  51.       IF(MSOLUT.EQ.0) GOTO 6
  52.       SEGACT MSOLUT
  53.       IF (ICHAN.EQ.0) KDEPL(ICAS)=MSOLIS(5)
  54.       IF (ICHAN.EQ.1) KDEPL(ICAS)=MSOLIS(6)
  55.       IMEL(ICAS)=MSOLIS(3)
  56.       SEGDES MSOLUT
  57.       IF(KDEPL(ICAS).EQ.0) THEN
  58.         MOTERR(1:8)=ITYSOL
  59.         CALL ERREUR(61)
  60.         SEGDES MSOBAS
  61.         RETURN
  62.       ENDIF
  63.       MSOLEN=KDEPL(ICAS)
  64.       SEGACT MSOLEN
  65.       LDEPL=LDEPL+ISOLEN(/1)
  66.       SEGDES MSOLEN
  67.     6 CONTINUE
  68.       SEGDES MSOBAS
  69.       LICPR=nbpts
  70.       SEGINI ICPR,ICPR1
  71. C
  72. C  **** FABRICATION DU TABLEAU ICC-ISS-IPP-NBB POUR CHAQUE PT DE SORTIE
  73. C  **** (BOUCLE 30)
  74. C  **** FABRICATION DU TABLEAU TRAV(LDEPL,N) DES MODES REDUITS AUX
  75. C  **** POINTS DE SORTIE (BOUCLE 40)
  76. C
  77.       JJJ=0
  78.       SEGINI ITRAV1
  79.       DO 50 ICAS=1,2
  80.       MSOLEN=KDEPL(ICAS)
  81.       IF(MSOLEN.EQ.0) GOTO 50
  82.       SEGINI ITRAV3
  83.       SEGACT MSOLEN
  84.       IF (ICHAN.EQ.0) THEN
  85.       MCHPOI=ISOLEN(1)
  86.       ELSE
  87.       ICHAM=ISOLEN(1)
  88. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  89. C*    CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1)
  90. C*    IF (IRET.EQ.0) THEN
  91. C*      CALL ERREUR(___)
  92. C*      RETURN
  93. C*    ENDIF
  94. C*    CALL CHAMPO(ICHAM2,2,MCHPOI,IRET)
  95.       CALL CHAMPO(ICHAM,2,MCHPOI,IRET)
  96.       IF (IRET.EQ.0) RETURN
  97.       ENDIF
  98.       SEGACT MCHPOI
  99.       NSOUPO=IPCHP(/1)
  100.       KK=0
  101.       DO 30 ISOU=1,NSOUPO
  102.       MSOUPO=IPCHP(ISOU)
  103.       SEGACT MSOUPO
  104.       NC=NOCOMP(/2)
  105.       MELEME=IGEOC
  106.       SEGACT MELEME
  107.       CALL IANUL(ICPR(1),LICPR)
  108.       DO 60 NB=1,NUM(/2)
  109.       ICPR(NUM(1,NB))=NB
  110.  60   CONTINUE
  111.       SEGDES MELEME
  112.       DO 61 I=1,N
  113.       IF(ICPR(NUMO(I)).NE.0) THEN
  114.         KK=KK+1
  115.         NBB(KK)=ICPR(NUMO(I))
  116.         NUJ=NUDDL(I)
  117.         DO 72 IC=1,NC
  118.         IF(NOCOMP(IC).EQ.NUJ) THEN
  119.           ICC(KK)=IC
  120.           ISS(KK)=ISOU
  121.           IPP(KK)=I
  122.           GOTO 61
  123.         ENDIF
  124.   72    CONTINUE
  125.         MOTERR=NUJ
  126.         CALL ERREUR(243)
  127. C       INCOMPATIBILITE POINT_COMPOSANTE
  128.         GOTO 5000
  129.       ENDIF
  130.  61   CONTINUE
  131.       SEGDES MSOUPO
  132.  30   CONTINUE
  133. C
  134.       IF(KK.NE.N) THEN
  135.         CALL ERREUR(18)
  136. C       IL MANQUE DES POINTS
  137.         GOTO 5000
  138.       ENDIF
  139. C
  140.       LDEP=ISOLEN(/1)
  141.       MELEME=IMEL(ICAS)
  142.       SEGACT MELEME
  143.       DO 40 I=1,LDEP
  144.       JJJ=JJJ+1
  145.       ICPR1(NUM(1,I))=JJJ
  146.       IF(I.EQ.1) GOTO 42
  147.       IF (ICHAN.EQ.0) THEN
  148.       MCHPOI=ISOLEN(I)
  149.       ELSE
  150.       ICHAM=ISOLEN(I)
  151. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  152. C*    CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1)
  153. C*    IF (IRET.EQ.0) THEN
  154. C*      CALL ERREUR(___)
  155. C*      RETURN
  156. C*    ENDIF
  157. C*    CALL CHAMPO(ICHAM2,2,MCHPOI,IRET)
  158.       CALL CHAMPO(ICHAM,2,MCHPOI,IRET)
  159.       IF (IRET.EQ.0) RETURN
  160.       ENDIF
  161.       SEGACT MCHPOI
  162.   42  CONTINUE
  163.       DO 41 IP=1,N
  164.       MSOUPO=IPCHP(ISS(IP))
  165.       SEGACT MSOUPO
  166.       MPOVAL=IPOVAL
  167.       SEGACT MPOVAL
  168.       TRAV(JJJ,IPP(IP))=VPOCHA(NBB(IP),ICC(IP))
  169.       SEGDES MPOVAL,MSOUPO
  170.    41 CONTINUE
  171.       IF (ICHAN.EQ.0) SEGDES MCHPOI
  172.       IF (ICHAN.EQ.1) SEGSUP MCHPOI
  173.    40 CONTINUE
  174.       SEGDES MSOLEN,MELEME
  175.       SEGSUP ITRAV3
  176.    50 CONTINUE
  177. C
  178.       SEGSUP ICPR
  179. C
  180. C  **** FABRICATION DE ITRAV(2,LDEPL), ET DE IPOS(NSOUP+1)
  181. C
  182.       MSOLEN=ILEX
  183.       SEGACT MSOLEN
  184.       MCHPOI=ISOLEN(1)
  185.       SEGACT MCHPOI
  186.       NSOUP=IPCHP(/1)
  187.       NSOUP1=NSOUP+1
  188.       SEGINI IPOS
  189.       SEGINI ITRAV
  190.       KK=0
  191.       IPOS(1)=0
  192.       DO 1 ISOU=1,NSOUP
  193.       MSOUPO=IPCHP(ISOU)
  194.       SEGACT MSOUPO
  195.       MELEME=IGEOC
  196.       SEGACT MELEME
  197.       DO 2 I=1,NUM(/2)
  198.       J=ICPR1(NUM(1,I))
  199.       IF(J.NE.0) THEN
  200.         KK=KK+1
  201.         ITRAV(1,KK)=I
  202.         ITRAV(2,KK)=J
  203.       ENDIF
  204.    2  CONTINUE
  205.       SEGDES MELEME,MSOUPO
  206.       IPOS(ISOU+1)=KK
  207.    1  CONTINUE
  208.       SEGSUP ICPR1
  209. C
  210. C **** BOUCLE SUR LES INSTANTS DE LA TABLE
  211. C
  212.       MSOLEN=ILEX
  213.       SEGACT MSOLEN
  214.       LTEM=ISOLEN(/1)
  215.       JG=LTEM
  216.       DO 99 JJ=1,N
  217.       SEGINI MLREEL
  218.       KLIST(JJ)=MLREEL
  219.    99 CONTINUE
  220. C
  221.       SEGINI ITRAV2
  222.       DO 90 L=1,LTEM
  223.       MCHPOI=ISOLEN(L)
  224.       SEGACT MCHPOI
  225.       DO 70 I=1,NSOUP
  226.       IF(IPOS(I+1).NE.IPOS(I)) THEN
  227.         MSOUPO=IPCHP(I)
  228.         SEGACT MSOUPO
  229.         MPOVAL=IPOVAL
  230.         SEGACT MPOVAL
  231.         DO 160 NB=IPOS(I)+1,IPOS(I+1)
  232.         TRAVV(ITRAV(2,NB))=VPOCHA(ITRAV(1,NB),1)
  233.  160    CONTINUE
  234.         SEGDES MPOVAL,MSOUPO
  235.       ENDIF
  236.   70  CONTINUE
  237.       SEGDES MCHPOI
  238.       DO 162 IP=1,N
  239.       CALL PROSC1(TRAVV,TRAV(1,IP),RET,LDEPL)
  240.       MLREEL=KLIST(IP)
  241.       PROG(L)=RET
  242. 162   CONTINUE
  243.  90   CONTINUE
  244. C
  245.       SEGSUP ITRAV
  246.       SEGSUP IPOS
  247.       SEGSUP ITRAV1,ITRAV2
  248.       DO 98 JJ=1,N
  249.       MLREEL=KLIST(JJ)
  250.       SEGDES MLREEL
  251.  98   CONTINUE
  252. C
  253.       SEGDES MSOLEN
  254.  5000 CONTINUE
  255.       RETURN
  256.       END
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  

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