1 : C EVOL1 SOURCE CHAT 05/01/12 23:47:03 5004 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 : -INC CCOPTIO 16 : -INC SMCHPOI 17 : -INC SMLENTI 18 : -INC SMLREEL 19 : -INC SMELEME 20 : SEGMENT NUMOO 21 : INTEGER NUMO(N),KLIST(N) 22 : CHARACTER*4 NUDDL(N) 23 : ENDSEGMENT 24 : SEGMENT/ITRAV/(NBB(N),ICC(N),ISS(N)) 25 : CHARACTER*4 NUJ 26 : C 27 : NUMOO=IBOO 28 : SEGACT NUMOO*MOD 29 : N=NUMO(/1) 30 : SEGINI ITRAV 31 : MLENTI=ILEX 32 : SEGACT MLENTI 33 : LTEM=LECT(/1) 34 : ISS=0 35 : C 36 : C *** PREMIER PASSAGE ON REPERE LE CHAMP ISS ICC NBB 37 : C 38 : MCHPOI=LECT (1) 39 : SEGACT MCHPOI 40 : NSOUPO=IPCHP(/1) 41 : KK=0 42 : DO 70 ISOU=1,NSOUPO 43 : MSOUPO=IPCHP(ISOU) 44 : SEGACT MSOUPO 45 : NC=NOCOMP(/2) 46 : MELEME=IGEOC 47 : SEGACT MELEME 48 : NBELEM=NUM(/2) 49 : DO 60 NB=1,NBELEM 50 : J=NUM(1,NB) 51 : DO 71 JJ=1,N 52 : IF(J.EQ.NUMO(JJ)) THEN 53 : NBB(JJ)=NB 54 : KK=KK+1 55 : NUJ=NUDDL(JJ) 56 : DO 72 IC=1,NC 57 : IF(NOCOMP(IC).EQ.NUJ) THEN 58 : ICC(JJ)=IC 59 : ISS(JJ)=ISOU 60 : GOTO 71 61 : ENDIF 62 : 72 CONTINUE 63 : MOTERR(1:4)=NUJ 63 : CALL ERREUR(243) 64 : C INCOMPATIBILITE ENTRE LA COMPOSANTE ET LE POINT 65 : GOTO 5000 66 : ENDIF 67 : 71 CONTINUE 68 : IF(KK.EQ.N) THEN 69 : SEGDES MELEME,MSOUPO 70 : GOTO 61 71 : ENDIF 72 : 60 CONTINUE 73 : SEGDES MELEME,MSOUPO 74 : 70 CONTINUE 75 : C 76 : INTERR(1)=J 77 : MOTERR(1:8)='CHPOINT' 77 : CALL ERREUR(64) 78 : C DES POINT N'APPARTIENNENT PAS AU CHAMP 79 : GOTO 5000 80 : C 81 : C ****** BOUCLE SUR LES CHPOINTS*************************** 82 : C 83 : 61 CONTINUE 84 : JG=LTEM 85 : DO 99 JJ=1,N 86 : SEGINI MLREEL 87 : KLIST(JJ)=MLREEL 88 : 99 CONTINUE 89 : C 90 : DO 90 L=1,LTEM 91 : MCHPOI=LECT (L) 92 : SEGACT MCHPOI 93 : DO 40 JJ=1,N 94 : MSOUPO=IPCHP(ISS(JJ)) 95 : SEGACT MSOUPO 96 : MPOVAL=IPOVAL 97 : SEGACT MPOVAL 98 : MLREEL=KLIST(JJ) 99 : PROG(L)=VPOCHA(NBB(JJ),ICC(JJ)) 100 : SEGDES MPOVAL,MSOUPO 101 : 40 CONTINUE 102 : SEGDES MCHPOI 103 : 90 CONTINUE 104 : C 105 : SEGSUP ITRAV 106 : DO 98 JJ=1,N 107 : MLREEL=KLIST(JJ) 108 : SEGDES MLREEL 109 : 98 CONTINUE 110 : C 111 : SEGSUP MLENTI 112 : 5000 CONTINUE 113 : RETURN 114 : END 115 : 116 :
© Cast3M 2003 - All rights reserved.
Disclaimer