1 : C MAPP SOURCE CHAT 07/10/29 21:23:55 5940 2 : SUBROUTINE MAPP 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C======================================================================= 7 : C = = 8 : C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LES POINTS D'UNE = 9 : C = SECTION DE POINCARE = 10 : C = = 11 : C = SYNTAXE : CART = MAPP (COUL) EVOLF EVOLD EVOLV = 12 : C = = 13 : C = SUR UN EVENEMENT SE PRODUISANT SUR EVOLF A L'ABSCISSE T, ON = 14 : C = EMPLIT CART AVEC L'ORDONNEE A L'ABSCISSE T DE EVOLD, EN ABSCISSE = 15 : C = ET L'ORDONNEE A L'ABSCISSE T DE EVOLV, EN ORDONNEE. = 16 : C = = 17 : C = L'EVENEMENT EST LE PASSAGE DE 0. A UNE VALEUR DE L'ORDONNEE DE = 18 : C = EVOLF = 19 : C = = 20 : C = = 21 : C = MEVOL1 : POINTEUR SUR MEVOLF (OBJET EVOLUTION) = 22 : C = MEVOL2 : POINTEUR SUR MEVOLD " " = 23 : C = IPOMEV : POINTEUR SUR MEVOLV " " = 24 : C = KEVOL1 : POINTEUR SUR KEVOLF = 25 : C = KEVOL2 : POINTEUR SUR KEVOLD = 26 : C = IPOKEV : POINTEUR SUR KEVOLV = 27 : C = MLREE1 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF = 28 : C = MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLD = 29 : C = IPOVIT : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV = 30 : C = = 31 : C = CREATION : 25/03/87 = 32 : C = PROGRAMMATEUR : BEAUFILS = 33 : C======================================================================= 34 : C 35 : -INC CCGEOME 36 : -INC CCOPTIO 37 : -INC SMEVOLL 38 : -INC SMLREEL 39 : C 40 : CHARACTER*12 MOTX,MOTY 41 : CHARACTER *72 TI 42 : C 42 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 43 : IF(ICOUL.EQ.0) ICOUL=IDCOUL+1 44 : ICOUL=ICOUL-1 45 : C 45 : CALL LIROBJ('EVOLUTIO',IPEV1,1,IRET) 45 : CALL LIROBJ('EVOLUTIO',IPEV2,1,IRET) 45 : CALL LIROBJ('EVOLUTIO',IPEV3,1,IRET) 46 : C 47 : IF(IERR.NE.0) GOTO 100 48 : C 49 : C LES 3 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR 50 : C 51 : MEVOL1=IPEV1 52 : SEGACT MEVOL1 53 : KEVOL1=MEVOL1.IEVOLL(1) 54 : SEGACT KEVOL1 55 : MLREE1=KEVOL1.IPROGY 56 : SEGACT MLREE1 57 : L1=MLREE1.PROG(/1) 58 : C 59 : MEVOL2=IPEV2 60 : SEGACT MEVOL2 61 : KEVOL2=MEVOL2.IEVOLL(1) 62 : SEGACT KEVOL2 63 : MOTX=KEVOL2.NOMEVY 64 : MLREE2=KEVOL2.IPROGY 65 : SEGACT MLREE2 66 : L2=MLREE2.PROG(/1) 67 : C 68 : MEVOLL=IPEV3 69 : IPOMEV=IPEV3 70 : SEGACT MEVOLL 71 : KEVOLL=IEVOLL(1) 72 : IPOKEV=IEVOLL(1) 73 : SEGACT KEVOLL 74 : MOTY=NOMEVY 75 : MLREE3=IPROGY 76 : SEGACT MLREE3 77 : L3=MLREE3.PROG(/1) 78 : C 79 : C 80 : IF((L1.EQ.L2).AND.(L1.EQ.L3))GOTO 10 80 : CALL ERREUR(337) 81 : GOTO 100 82 : C 83 : C CREATION DE L'OBJET CART DE TYPE EVOLUTIO 84 : C 85 : 10 CONTINUE 86 : N=1 87 : SEGINI MEVOLL 88 : IPMAP=MEVOLL 89 : TI(1:72)=TITREE 90 : IEVTEX=TI 91 : ITYEVO='REEL' 92 : SEGINI KEVOLL 93 : IEVOLL(1)=KEVOLL 94 : TYPX='LISTREEL' 95 : TYPY='LISTREEL' 96 : KEVTEX=TI 97 : C 98 : NOMEVX=MOTX 99 : NOMEVY=MOTY 100 : NUMEVX=ICOUL 101 : NUMEVY='REEL' 102 : C 103 : JG=0 104 : SEGINI MLREEL 105 : IPROGX=MLREEL 106 : SEGINI MLREEL 107 : IPROGY=MLREEL 108 : C 109 : C L'EVENEMENT EST PRIS SUR LE PREMIER OBJET EVOLUTION CITE EN 110 : C ARGUMENT 111 : C 112 : ICHO=0 113 : DO 20 I=1,L1 114 : FORC=MLREE1.PROG(I) 115 : IF(ABS(FORC).GT.1.E-10) THEN 116 : C 117 : C IL Y A CHOC 118 : C 119 : IF(ICHO.EQ.0) THEN 120 : C 121 : C ON TIENT L'EVENEMENT 122 : C 123 : ICHO=1 124 : C 125 : C LE DEUXIEME OBJET EVOL CONCERNE LE DEPLACEMENT D'UN POINT 126 : C LE TROISIEME OBJET EVOL CONCERNE LA VITESSE DU MEME POINT 127 : C 128 : DEPL=MLREE2.PROG(I) 129 : VITE=MLREE3.PROG(I) 130 : C 131 : C DEPL ET VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR MAPP 132 : C 133 : MLREEL=IPROGX 134 : JG=PROG(/1) 135 : SEGADJ MLREEL 136 : PROG(JG)=DEPL 137 : MLREEL=IPROGY 138 : SEGADJ MLREEL 139 : PROG(JG)=VITE 140 : C 141 : ENDIF 142 : C 143 : C PAS DE CHOC 144 : C 145 : ELSE 146 : ICHO=0 147 : ENDIF 148 : C 149 : 20 CONTINUE 150 : C 151 : C DESACTIVE LES LISTREEL 152 : C 153 : MLREEL=IPROGX 154 : SEGDES MLREEL 155 : MLREEL=IPROGY 156 : SEGDES MLREEL 157 : SEGDES MLREE3,MLREE1,MLREE2 158 : C 159 : C DESACTIVE LES MEVOL ET AUTRES KEVOL 160 : C 161 : C 162 : SEGDES KEVOLL,MEVOLL 163 : SEGDES KEVOL1,MEVOL1 164 : SEGDES KEVOL2,MEVOL2 165 : KEVOLL=IPOKEV 166 : MEVOLL=IPOMEV 167 : SEGDES KEVOLL,MEVOLL 168 : C 168 : CALL ECROBJ('EVOLUTIO',IPMAP) 169 : C 170 : 100 CONTINUE 171 : RETURN 172 : END 173 : 174 : 175 : 176 : 177 : 178 : 179 : 180 :
© Cast3M 2003 - All rights reserved.
Disclaimer