1 : C PUEVOL SOURCE BP208322 12/11/06 21:15:06 7562 2 : SUBROUTINE PUEVOL(IPEV1,XP1,IP1,IEVPU,IRETO) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : CHARACTER *72 TI 6 : CHARACTER*4 CTYP1,MOTY3 7 : CHARACTER*12 MOTX1 8 : CHARACTER*4 MOTY(8),MOTY1 9 : LOGICAL INF1,TEST1 10 : C 11 : C======================================================================= 12 : C 13 : C CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LA PUISSANCE 14 : C ENTIERE D'UN OBJET EVOLUTIOn 15 : C 16 : C SYNTAXE : PUIS = EVOLF ** NN 17 : C 18 : C ON EXECUTE LA PUISSANCE ENTIERE DES ORDONNEES DE L'EVOLUTIOn. 19 : C L'ABSCISSE DE L'OBJET AINSI CREE RESTE CELLE DE L'EVOLUTIOn EN 20 : C ENTREE. 21 : C 22 : C ENTREES : 23 : C IPEV1 = POINTEUR SUR L'OBJET EVOLUTIOn E ELEVER A LA PUISSANCE 24 : C XP1 = PUISSANCE REELLE 25 : C IP1 = PUISSANCE ENTIERE 26 : C IRETO = 2 SI PUISSANCE REELLE 27 : C = 1 SI PUISSANCE ENTIERE 28 : C 29 : C SORTIES : 30 : C IEVPU = POINTEUR SUR L'OBJET EVOLUTIOn RESULTAT 31 : C = 0 SI PB 32 : C IRETO = 1 33 : C = 0 SI UNE COMPOSANTE EST NEGATIVE 34 : C 35 : C VARIABLES LOCALES : 36 : C 37 : C MEVOL1 : POINTEUR SUR MEVOLL (OBJET EVOLUTION) 38 : C KEVOL1 : POINTEUR SUR KEVOLL 39 : C MLREE1 : POINTEUR SUR LA LISTREEL ABSCISSE DE EVOLL 40 : C MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLL 41 : C 42 : C 43 : C======================================================================= 44 : C 45 : -INC CCGEOME 46 : -INC CCOPTIO 47 : -INC SMEVOLL 48 : -INC SMLREEL 49 : -INC SMLMOTS 50 : -INC CCREEL 51 : C 52 : POINTEUR MLREE4.MLREEL 53 : C 54 : DATA MOTY(1),MOTY(2),MOTY(3),MOTY(4)/'DEPL','VITE','ACCE','FORC'/ 55 : DATA MOTY(5),MOTY(6),MOTY(7),MOTY(8)/'BRUI','REEL','IMAG','LIAI'/ 56 : C 57 : XGRNEG=-1.D0*XGRAND 58 : c 59 : IEVPU=0 60 : IFLO=IRETO 61 : IRETO=1 62 : C 63 : cbp Lecture eventuelle d'une couleur pour toutes les sous evolutions 63 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 64 : cbp IF(ICOUL.EQ.0) ICOUL=IDCOUL+1 65 : cbp ICOUL=ICOUL-1 66 : 67 : 68 : C 69 : C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR 70 : C L'UN EST UNE FORCE, L'AUTRE UNE VITESSE 71 : C 72 : MEVOL1=IPEV1 73 : SEGACT MEVOL1 74 : C 75 : C TEST SUR LE SOUS-TYPE 76 : C 77 : CTYP1=MEVOL1.ITYEVO 78 : IF (CTYP1.NE.'COMP') GO TO 199 79 : SEGDES MEVOL1 80 : RETURN 81 : 199 CONTINUE 82 : C 83 : C BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT 84 : C 85 : NC1=MEVOL1.IEVOLL(/1) 86 : N=NC1 87 : SEGINI MEVOLL 88 : IEVPU=MEVOLL 89 : TI(1:72)=TITREE 90 : IEVTEX=TI 91 : ITYEVO='REEL' 92 : DO 201 IC=1,NC1 93 : KEVOL1=MEVOL1.IEVOLL(IC) 94 : SEGACT KEVOL1 95 : DO 50 I=1,3 96 : DO 50 J=1,8 97 : IF (KEVOL1.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN 98 : MOTY1=KEVOL1.NOMEVY(I*4-3:I*4) 99 : GOTO 51 100 : ENDIF 101 : 50 CONTINUE 102 : MOTX1=KEVOL1.NOMEVX(1:4) 103 : MOTY1=KEVOL1.NOMEVY(1:4) 104 : C 105 : C 106 : 51 MLREE2=KEVOL1.IPROGY 107 : IF (KEVOL1.NUMEVY.NE.'REEL'.AND. 108 : & KEVOL1.NUMEVY.NE.'HIST') GOTO 1000 109 : SEGACT MLREE2 110 : IF (KEVOL1.TYPY.NE.'LISTMOTS') THEN 111 : L1=MLREE2.PROG(/1) 112 : ELSE 113 : MLMOT1=KEVOL1.IPROGY 114 : SEGACT MLMOT1 115 : L1=MLMOT1.MOTS(/2) 116 : SEGDES MLMOT1 117 : ENDIF 118 : SEGDES MLREE2 119 : C 120 : C 121 : C CREATION DE L'OBJET PROD DE TYPE EVOLUTIO 122 : C 123 : C 124 : MLREE1=KEVOL1.IPROGX 125 : MLREE2=KEVOL1.IPROGY 126 : SEGACT MLREE1,MLREE2 127 : SEGINI KEVOLL 128 : IEVOLL(IC)=KEVOLL 129 : C 130 : TYPX='LISTREEL' 131 : TYPY='LISTREEL' 132 : KEVTEX=TI 133 : NOMEVX=MOTX1 134 : IF (IFLO.EQ.1) THEN 135 : WRITE(MOTY3,'(I4)') INT(XP1) 136 : NOMEVY=MOTY1(1:4)//'**'//MOTY3(1:4) 137 : ELSE 138 : WRITE(MOTY3,'(F4.1)') XP1 139 : NOMEVY=MOTY1(1:4)//'** '//MOTY3(1:4) 140 : ENDIF 141 : cbp NUMEVX=ICOUL 142 : cbp tant qu'on peut, on conserve la couleur 143 : if(ICOUL.ne.0) then 144 : NUMEVX = ICOUL-1 145 : else 146 : NUMEVX = KEVOL1.NUMEVX 147 : endif 148 : NUMEVY='REEL' 149 : C 150 : JG=L1 151 : SEGINI,MLREE3=MLREE1 152 : IPROGX=MLREE3 153 : SEGINI,MLREE4 154 : IPROGY=MLREE4 155 : c IF (XP1.GT.0.) THEN 156 : c DO 20 I=1,L1 157 : c X=MLREE1.PROG(I) 158 : c Y=MLREE2.PROG(I) 159 : c MLREE3.PROG(I)=X 160 : c MLREE4.PROG(I)=Y**XP1 161 : c 20 CONTINUE 162 : c ELSE 163 : c DO 21 I=1,L1 164 : c X=MLREE1.PROG(I) 165 : c Y=MLREE2.PROG(I) 166 : c MLREE3.PROG(I)=X 167 : c IF (Y.GT.1.E-20) THEN 168 : c MLREE4.PROG(I)=Y**XP1 169 : c ELSE 170 : c GOTO 1001 171 : c ENDIF 172 : c 21 CONTINUE 173 : c ENDIF 174 : c 175 : c bp: ci dessus donne des NAN si Y<0 et XP1>0, on préfère : 176 : c 177 : IF (IFLO.EQ.1) THEN 178 : DO 20 I=1,L1 179 : cbp2012 X=MLREE1.PROG(I) 180 : Y=MLREE2.PROG(I) 181 : cbp2012 MLREE3.PROG(I)=X 182 : MLREE4.PROG(I)=Y**IP1 183 : 20 CONTINUE 184 : TEST1=IP1.lt.0 185 : c bp (05/2012) : ajout du cas SQRT 186 : ELSEIF(XP1.eq.0.5D0) THEN 187 : DO 21 I=1,L1 188 : cbp2012 X=MLREE1.PROG(I) 189 : Y=MLREE2.PROG(I) 190 : cbp2012 MLREE3.PROG(I)=X 191 : IF(Y.LT.0.D0) GOTO 1001 192 : MLREE4.PROG(I)=sqrt(Y) 193 : 21 CONTINUE 194 : TEST1 = .false. 195 : ELSE 196 : DO 22 I=1,L1 197 : cbp2012 X=MLREE1.PROG(I) 198 : Y=MLREE2.PROG(I) 199 : cbp2012 MLREE3.PROG(I)=X 200 : IF(Y.LT.0.D0) GOTO 1001 201 : MLREE4.PROG(I)=Y**XP1 202 : 22 CONTINUE 203 : TEST1=XP1.lt.0.D0 204 : ENDIF 205 : c 206 : c on ajoute un petit avertissement en présence d'INF 207 : c (pas une erreur car ce resultat peut etre intermediaire et 208 : c finalement 1/INF=0 donc on peut continuer) 209 : INF1=.false. 210 : if (TEST1) then 211 : do i=1,L1 212 : Y=MLREE4.PROG(i) 213 : if(Y.gt.XGRAND) INF1=.true. 214 : enddo 215 : endif 216 : if(INF1) write(IOIMP,*) 217 : & 'Attention: au moins une valeur est INFinie' 218 : C 219 : C DESACTIVE LES LISTREEL 220 : C 221 : SEGDES MLREE3,MLREE4 222 : SEGDES MLREE1,MLREE2 223 : C 224 : C DESACTIVE LES KEVOL 225 : C 226 : SEGDES KEVOLL 227 : SEGDES KEVOL1 228 : C 229 : 201 CONTINUE 230 : C 231 : C DESACTIVE LES MEVOL 232 : C 233 : SEGDES MEVOLL 234 : SEGDES MEVOL1 235 : C 236 : 100 CONTINUE 237 : RETURN 238 : 1000 CONTINUE 239 : MOTERR(1:8 )='EVOLUTIO' 240 : MOTERR(9:13)=KEVOL1.NUMEVY 240 : CALL ERREUR(131) 241 : RETURN 242 : 1001 CONTINUE 242 : CALL ERREUR(213) 243 : RETURN 244 : 2001 FORMAT(I1) 245 : 2002 FORMAT(I2) 246 : 2003 FORMAT(I3) 247 : 2004 FORMAT(I4) 248 : END 249 : 250 : 251 : 252 : 253 : 254 :
© Cast3M 2003 - All rights reserved.
Disclaimer