1 : C OPCHEL SOURCE PV 09/03/12 21:29:52 6325 2 : SUBROUTINE OPCHEL(IPO1,IEPS,IRET) 3 : C===================================================================== 4 : C 5 : C EFFECTUE DIVERSES OPERATIONS SUR DES MCHAML 6 : C ENTREES 7 : C IPO1=POINTEUR SUR LE CHAMPS PAR ELEMENT 8 : C IEPS= 1 COSINUS 9 : C = 2 SINUS 10 : C = 3 TANGENTE L INFINI PAR 0 11 : C = 4 ARCOSINUS VIRER LES MODULOS 12 : C = 5 ARCSINUS VIRER LES MODULOS 13 : C = 6 ARCTANGENTE 14 : C = 7 EXPONENTIELLE 15 : C = 8 LOGARITHME 16 : C = 9 VALEUR ABSOLUE 17 : C =10 COSINUS HYPERBOLIQUE 18 : C =11 SINUS HYPERBOLIQUE 19 : C =12 TANGENTE HYPERBOLIQUE 20 : C =13 ERF FONCTION D'ERRREUR DE GAUSS 21 : C SORTIES 22 : C IRET=POINTEUR SUR LE CHAMP RESULTANT 23 : C =0 SI OPERATION IMPOSSSIBLE 24 : C 25 : C PASSAGE AUX NOUVEAUX CHAMELEMS LE 3 09 90 PAR I.MONNIER 26 : C 27 : C===================================================================== 28 : C 29 : IMPLICIT INTEGER(I-N) 30 : IMPLICIT REAL*8(A-H,O-Z) 31 : C 32 : -INC SMCHAML 33 : -INC CCOPTIO 34 : -INC CCREEL 35 : C 36 : PARAMETER (CEN180=180.D0) 37 : C 38 : XCONV=XPI/CEN180 39 : XVNOC=CEN180/XPI 40 : IRET=0 41 : MCHEL1 = IPO1 42 : SEGINI,MCHELM=MCHEL1 43 : IRET = MCHELM 44 : NSOUS = IMACHE(/1) 45 : * 46 : DO 72 IA=1,NSOUS 47 : * 48 : MCHAM1=ICHAML(IA) 49 : SEGINI,MCHAML=MCHAM1 50 : ICHAML(IA)=MCHAML 51 : * 52 : DO 75 ICOMP=1,IELVAL(/1) 53 : * 54 : MELVA1 = IELVAL(ICOMP) 55 : SEGINI,MELVAL=MELVA1 56 : IELVAL(ICOMP) = MELVAL 57 : SEGACT MELVA1 58 : * 59 : IF (TYPCHE(ICOMP).EQ.'REAL*8') GOTO 1666 60 : C 61 : GOTO 166 62 : C 63 : 1666 N1PTEL=VELCHE(/1) 64 : N1EL =VELCHE(/2) 65 : GOTO( 1, 2,66,66,66, 6, 7, 8, 9,10,11,12,13),IEPS 66 : 66 IRET=0 67 : GOTO 666 68 : 1 CONTINUE 69 : C 70 : C COSINUS 71 : C 72 : DO 1000 IB=1,N1PTEL 73 : DO 1001 ID=1,N1EL 74 : XX=MELVA1.VELCHE(IB,ID) 75 : XX=XX*XCONV 76 : VELCHE(IB,ID)=COS(XX) 77 : 1001 CONTINUE 78 : 1000 CONTINUE 79 : GOTO 166 80 : C 81 : C SINUS 82 : C 83 : 2 CONTINUE 84 : DO 20 IB=1,N1PTEL 85 : DO 21 ID=1,N1EL 86 : XX =MELVA1.VELCHE(IB,ID) 87 : XX=XX*XCONV 88 : VELCHE(IB,ID)=SIN(XX) 89 : 21 CONTINUE 90 : 20 CONTINUE 91 : GOTO 166 92 : C 93 : C TANGENTE 94 : C 95 : * 3 CONTINUE 96 : * DO 30 IB=1,N1PTEL 97 : * DO 31 ID=1,N1EL 98 : * XX=MELVA1.VELCHE(IB,ID) 99 : * XX=XX*XCONV 100 : * VELCHE(IB,ID)=DTAN(XX) 101 : * 31 CONTINUE 102 : * 30 CONTINUE 103 : * GOTO 166 104 : *C 105 : *C ARCOSINUS 106 : *C 107 : * 4 CONTINUE 108 : * DO 40 IB=1,N1PTEL 109 : * DO 41 ID=1,N1EL 110 : * XX=MELVA1.VELCHE(IB,ID) 111 : * XX=XVNOC*ACOS(XX) 112 : * VELCHE(IB,ID)=XX 113 : * 41 CONTINUE 114 : * 40 CONTINUE 115 : * GOTO 166 116 : *C 117 : *C ARCSINUS 118 : *C 119 : * 5 CONTINUE 120 : * DO 50 IB=1,N1PTEL 121 : * DO 51 ID=1,N1EL 122 : * XX=MELVA1.VELCHE(IB,ID) 123 : * XX=XVNOC*DASIN(XX) 124 : * VELCHE(IB,ID)=XX 125 : * 51 CONTINUE 126 : * 50 CONTINUE 127 : * GOTO 166 128 : C 129 : C ARCTANGENTE 130 : C 131 : 6 CONTINUE 132 : DO 60 IB=1,N1PTEL 133 : DO 61 ID=1,N1EL 134 : XX=MELVA1.VELCHE(IB,ID) 135 : XX=XVNOC*ATAN(XX) 136 : VELCHE(IB,ID)=XX 137 : 61 CONTINUE 138 : 60 CONTINUE 139 : GOTO 166 140 : C 141 : C EXPONENTIELLE 142 : C 143 : 7 CONTINUE 144 : DO 70 IB=1,N1PTEL 145 : DO 71 ID=1,N1EL 146 : XX=MELVA1.VELCHE(IB,ID) 147 : XX=EXP(XX) 148 : VELCHE(IB,ID)=XX 149 : 71 CONTINUE 150 : 70 CONTINUE 151 : GOTO 166 152 : C 153 : C LOGARITME 154 : C 155 : 8 CONTINUE 156 : DO 80 IB=1,N1PTEL 157 : DO 81 ID=1,N1EL 158 : XX=MELVA1.VELCHE(IB,ID) 159 : * 160 : IF(XX.LT.XPETIT) THEN 161 : IRET=0 161 : CALL ERREUR(36) 162 : SEGSUP MELVAL,MCHELM 163 : SEGDES MELVA1,MCHEL1 164 : RETURN 165 : ENDIF 166 : * 167 : XX=LOG(XX) 168 : VELCHE(IB,ID)=XX 169 : 81 CONTINUE 170 : 80 CONTINUE 171 : GOTO 166 172 : C 173 : C VALEUR ABSOLUE 174 : C 175 : 9 CONTINUE 176 : DO 90 IB=1,N1PTEL 177 : DO 91 ID=1,N1EL 178 : XX=MELVA1.VELCHE(IB,ID) 179 : XX=ABS(XX) 180 : VELCHE(IB,ID)=XX 181 : 91 CONTINUE 182 : 90 CONTINUE 183 : GOTO 166 184 : C 185 : C COSINUS HYPERBOLIQUE 186 : C 187 : 10 CONTINUE 188 : DO 100 IB=1,N1PTEL 189 : DO 101 ID=1,N1EL 190 : XX=MELVA1.VELCHE(IB,ID) 191 : XX=COSH(XX) 192 : VELCHE(IB,ID)=XX 193 : 101 CONTINUE 194 : 100 CONTINUE 195 : GOTO 166 196 : C 197 : C SINUS HYPERBOLIQUE 198 : C 199 : 11 CONTINUE 200 : DO 110 IB=1,N1PTEL 201 : DO 111 ID=1,N1EL 202 : XX=MELVA1.VELCHE(IB,ID) 203 : XX=SINH(XX) 204 : VELCHE(IB,ID)=XX 205 : 111 CONTINUE 206 : 110 CONTINUE 207 : GOTO 166 208 : C 209 : C TANGENTE HYPERBOLIQUE 210 : C 211 : 12 CONTINUE 212 : DO 120 IB=1,N1PTEL 213 : DO 121 ID=1,N1EL 214 : XX=MELVA1.VELCHE(IB,ID) 215 : XX=TANH(XX) 216 : VELCHE(IB,ID)=XX 217 : 121 CONTINUE 218 : 120 CONTINUE 219 : GOTO 166 220 : C 221 : C ERF 222 : C 223 : 13 CONTINUE 224 : DO 130 IB=1,N1PTEL 225 : DO 131 ID=1,N1EL 226 : XX = MELVA1.VELCHE(IB,ID) 227 : YY = ERGAUS(XX) 228 : VELCHE(IB,ID)=YY 229 : 131 CONTINUE 230 : 130 CONTINUE 231 : * 232 : 166 CONTINUE 233 : SEGDES MELVAL 234 : SEGDES MELVA1 235 : * 236 : 75 CONTINUE 237 : SEGDES MCHAML 238 : * 239 : 72 CONTINUE 240 : SEGDES MCHELM 241 : 666 CONTINUE 242 : RETURN 243 : END 244 : 245 : 246 : 247 : 248 : 249 : 250 : 251 : 252 : 253 : 254 : 255 : 256 : 257 : 258 : 259 : 260 :
© Cast3M 2003 - All rights reserved.
Disclaimer