Télécharger la plaquette Cast3M


fr en

Télécharger evol1.eso

Retour à la liste

Numérotation des lignes : 

evol1

  1. C EVOL1     SOURCE    BP208322  22/09/09    21:15:02     11448          
  2.       SUBROUTINE EVOL1(IBOO,ILEX)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C=======================================================================
  6. C SOUS-PROGRAMME APPELE PAR EVOLL1
  7. C FABRIQUE LE(S) LISTREEL KLIST A PARTIR DE LA SUITE DES CHAMPOINTS
  8. C CONTENUE DANS LE SEGMENT MLENTIPOINTE PAR ILEX
  9. C
  10. C
  11. C CREATION    : 16/10/85
  12. C PROGRAMMEUR : FARVACQUE
  13. C=======================================================================
  14. C
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC SMCHPOI
  19. -INC SMLENTI
  20. -INC SMLREEL
  21. -INC SMELEME
  22.       SEGMENT NUMOO
  23.        INTEGER NUMO(N),KLIST(N)
  24.        CHARACTER*(LOCHPO) NUDDL(N)
  25.       ENDSEGMENT
  26.       SEGMENT/ITRAV/(NBB(N),ICC(N),ISS(N))
  27.       CHARACTER*(LOCOMP) NUJ
  28. C
  29.       NUMOO=IBOO
  30.       SEGACT NUMOO*MOD
  31.       N=NUMO(/1)
  32.       SEGINI ITRAV
  33.       MLENTI=ILEX
  34.       SEGACT MLENTI
  35.       LTEM=LECT(/1)
  36.       ISS=0
  37. C
  38. C *** PREMIER PASSAGE ON REPERE LE CHAMP ISS ICC NBB
  39. C
  40.       MCHPOI=LECT  (1)
  41.       SEGACT MCHPOI
  42.       NSOUPO=IPCHP(/1)
  43.       KK=0
  44.       DO 70 ISOU=1,NSOUPO
  45.       MSOUPO=IPCHP(ISOU)
  46.       SEGACT MSOUPO
  47.       NC=NOCOMP(/2)
  48.       MELEME=IGEOC
  49.       SEGACT MELEME
  50.       NBELEM=NUM(/2)
  51.       DO 60 NB=1,NBELEM
  52.       J=NUM(1,NB)
  53.       DO 71 JJ=1,N
  54.       IF(J.EQ.NUMO(JJ)) THEN
  55.           NBB(JJ)=NB
  56.           KK=KK+1
  57.           NUJ=NUDDL(JJ)
  58.           DO 72 IC=1,NC
  59.           IF(NOCOMP(IC).EQ.NUJ) THEN
  60.               ICC(JJ)=IC
  61.               ISS(JJ)=ISOU
  62.               GOTO 71
  63.           ENDIF
  64.  72       CONTINUE
  65.           MOTERR(1:4)=NUJ
  66.           CALL ERREUR(243)
  67. C         INCOMPATIBILITE ENTRE LA COMPOSANTE ET LE POINT
  68.           GOTO 5000
  69.       ENDIF
  70.  71   CONTINUE
  71.       IF(KK.EQ.N) THEN
  72.          SEGDES MELEME,MSOUPO
  73.          GOTO 61
  74.       ENDIF
  75.  60   CONTINUE
  76.       SEGDES MELEME,MSOUPO
  77.  70   CONTINUE
  78. C
  79.       INTERR(1)=J
  80.       MOTERR(1:8)='CHPOINT'
  81.       CALL ERREUR(64)
  82. C     DES POINT N'APPARTIENNENT PAS AU CHAMP
  83.       GOTO 5000
  84. C
  85. C  ****** BOUCLE SUR LES CHPOINTS***************************
  86. C
  87.   61  CONTINUE
  88.       JG=LTEM
  89.       DO 99 JJ=1,N
  90.       SEGINI MLREEL
  91.       KLIST(JJ)=MLREEL
  92.  99   CONTINUE
  93. C
  94.       DO 90 L=1,LTEM
  95.       MCHPOI=LECT  (L)
  96.       SEGACT MCHPOI
  97.       DO 40 JJ=1,N
  98.       MSOUPO=IPCHP(ISS(JJ))
  99.       SEGACT MSOUPO
  100.       MPOVAL=IPOVAL
  101.       SEGACT MPOVAL
  102.       MLREEL=KLIST(JJ)
  103.       PROG(L)=VPOCHA(NBB(JJ),ICC(JJ))
  104.       SEGDES MPOVAL,MSOUPO
  105.  40   CONTINUE
  106.       SEGDES MCHPOI
  107.    90 CONTINUE
  108. C
  109.       SEGSUP ITRAV
  110.       DO 98 JJ=1,N
  111.       MLREEL=KLIST(JJ)
  112.       SEGDES MLREEL
  113.   98  CONTINUE
  114. C
  115.       SEGSUP MLENTI
  116.  5000 CONTINUE
  117.       RETURN
  118.       END
  119.  
  120.  
  121.  
  122.  
  123.  

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