1 : C PULIRF SOURCE BP208322 12/05/24 21:15:06 7378 2 : SUBROUTINE PULIRF(IPO1,XFLOT,IENTI,IPO2,IRET) 3 : C======================================================================= 4 : C 5 : C ENTREES 6 : C IPO1 = POINTEUR SUR LE LISTREEL A ELEVER A LA PUISSANCE 7 : C XFLOT ou IENTI 8 : C IRET = 2 SI PUISSANCE REELLE (XFLOT) 9 : C = 1 SI PUISSANCE ENTIERE (IENTI) 10 : C XFLOT = REEL (POSITIF OU NEGATIF) 11 : C IENTI = ENTIER (POSITIF OU NEGATIF) 12 : C SORTIES 13 : C IPO2 = POINTEUR SUR LE LISTREEL RESULTANT 14 : C 15 : C CODE BEAUFILS MAI 87 16 : C 17 : C======================================================================= 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8 (A-H,O-Z) 20 : LOGICAL INF1,TEST1 21 : -INC CCOPTIO 22 : -INC SMLREEL 23 : -INC CCREEL 24 : C 25 : XGRNEG=-1.D0*XGRAND 26 : c 27 : MLREE1=IPO1 28 : SEGACT MLREE1 29 : NP=MLREE1.PROG(/1) 30 : C 31 : C INITIALISATION DU LISTREEL 32 : C 33 : JG=NP 34 : SEGINI MLREEL 35 : IPO2=MLREEL 36 : C 37 : IF(IRET.EQ.1)GOTO 4 38 : C======================================================================= 39 : C L'EXPOSANT EST UN REEL 40 : C 41 : c PREC=1.E-20 42 : c bp: PREC est arbitraire et inutile : laissons la machine faire son job 43 : c 44 : c On ne peut pas élever à une puissance réelle un nombre négatif 45 : c sous peine d obtenir NAN 46 : ISTO=0 47 : DO II=1,NP 48 : IF((MLREE1.PROG(II)).LT.0.D0)ISTO=1 49 : ENDDO 50 : IF (ISTO.EQ.1) THEN 50 : CALL ERREUR(213) 51 : SEGDES MLREE1 52 : SEGSUP MLREEL 53 : RETURN 54 : ENDIF 55 : C 56 : c cas particulier Y**0 = 1 57 : IF (XFLOT.EQ.0.D0) THEN 58 : DO 1 II=1,NP 59 : PROG(II)=1.D0 60 : 1 CONTINUE 61 : TEST1=.false. 62 : C 63 : c bp (05/2012) : ajout du cas SQRT 64 : ELSEIF (XFLOT.EQ.0.5D0) THEN 65 : DO II=1,NP 66 : PROG(II)=SQRT(MLREE1.PROG(II)) 67 : ENDDO 68 : TEST1=.false. 69 : C 70 : ELSE 71 : DO II=1,NP 72 : c IF (ABS(MLREE1.PROG(II)).LE.PREC) THEN 73 : c PROG(II)=0.D0 74 : c ELSE 75 : PROG(II)=MLREE1.PROG(II)**XFLOT 76 : c ENDIF 77 : ENDDO 78 : TEST1=XFLOT.lt.0.D0 79 : ENDIF 80 : GOTO 100 81 : C 82 : C======================================================================= 83 : C L'EXPOSANT EST UN ENTIER 84 : C 85 : 4 IF (IENTI.EQ.0) THEN 86 : DO 5 II=1,NP 87 : PROG(II)=1.D0 88 : 5 CONTINUE 89 : TEST1=.false. 90 : C 91 : ELSE 92 : DO 6 II=1,NP 93 : PROG(II)=MLREE1.PROG(II)**IENTI 94 : 6 CONTINUE 95 : TEST1=IENTI.lt.0 96 : ENDIF 97 : C 98 : C======================================================================= 99 : 100 CONTINUE 100 : c 101 : c on ajoute un petit avertissement en présence d'INF 102 : c (pas une erreur car ce resultat peut etre intermediaire et 103 : c finalement 1/INF=0 donc on peut continuer) 104 : INF1=.false. 105 : if (TEST1) then 106 : do ii=1,NP 107 : Y=PROG(ii) 108 : if(Y.gt.XGRAND.or.Y.lt.XGRNEG) INF1=.true. 109 : enddo 110 : endif 111 : if(INF1) write(6,*)'Attention: au moins une valeur est INFinie' 112 : 113 : C WRITE(IOIMP,*)NP 114 : C WRITE(IOIMP,*)(PROG(I),I=1,NP) 115 : SEGDES MLREE1 116 : SEGDES MLREEL 117 : 666 CONTINUE 118 : RETURN 119 : END 120 : 121 : 122 : 123 :
© Cast3M 2003 - All rights reserved.
Disclaimer