1 : C ARCCS SOURCE PV 09/03/12 21:15:27 6325 2 : C ARCCS 3 : SUBROUTINE ARCCS(IOPT) 4 : *============================================================= 5 : * 6 : * ARC-COSINUS (si IOPT=1) 7 : * ARC-SINUS (si IOPT=2) 8 : * 9 : *============================================================= 10 : * 11 : * Création : Maugis 24/09/2007 12 : * Modifications : Gounand 18/12/2007 13 : * Petit rattrapage si argument proche de 1 14 : * 15 : *============================================================= 16 : * 17 : * REMARQUES: 18 : * 19 : *============================================================= 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8 (A-H,O-Z) 22 : -INC CCREEL 23 : -INC CCOPTIO 24 : -INC SMCHPOI 25 : -INC SMELEME 26 : -INC SMLREEL 27 : -INC SMCOORD 28 : -INC TMTRAV 29 : -INC SMCHAML 30 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 31 : REAL*8 Y 32 : CHARACTER*8 ITYP 33 : * Option de calcul 34 : IF (IOPT.NE.1 .AND. IOPT.NE.2) THEN 35 : * Erreur anormale.contactez votre support 35 : CALL ERREUR(5) 36 : ENDIF 37 : 38 : * Un objet de type CHPOINT, LISTREEL, ENTIER ou FLOTTANT est attendu. 38 : CALL MESLIR(-134) 39 : * Un nombre un peu plus grand que 1.D0 40 : XUNP = 1.D0 + (XZPREC ** 0.5D0) 41 : XUN = 1.D0 42 : * Facteur de conversion radian -> degrés 43 : XRADEG = 180.D0/XPI 44 : * 45 : * CAS DES CHPOINTS 46 : * 46 : CALL LIROBJ ('CHPOINT',MCHPO1,0,IRETOU) 47 : IF(IRETOU.NE.0) THEN 48 : SEGINI,MCHPOI=MCHPO1 49 : NS=IPCHP(/1) 50 : DO I = 1,NS 51 : MSOUP1 = IPCHP(I) 52 : SEGINI,MSOUPO=MSOUP1 53 : IPCHP(I)= MSOUPO 54 : IPT1 = IGEOC 55 : SEGINI,IPT2=IPT1 56 : SEGDES IPT2 57 : IGEOC = IPT2 58 : MPOVA1 = IPOVAL 59 : SEGINI,MPOVAL=MPOVA1 60 : IPOVAL = MPOVAL 61 : DO K=1,VPOCHA(/2) 62 : DO J=1,VPOCHA(/1) 63 : Y = VPOCHA(J,K) 64 : IF (ABS(Y).GT.XUN) THEN 65 : IF (ABS(Y).GT.XUNP) THEN 66 : SEGDES MPOVAL,MSOUPO,MCHPOI 67 : GOTO 999 68 : ELSE 69 : Y=SIGN(XUN,Y) 70 : ENDIF 71 : ENDIF 72 : IF (IOPT.EQ.1) THEN 73 : VPOCHA(J,K) = ACOS(Y)*XRADEG 74 : ELSE 75 : VPOCHA(J,K) = ASIN(Y)*XRADEG 76 : ENDIF 77 : ENDDO 78 : ENDDO 79 : SEGDES MPOVAL,MSOUPO 80 : ENDDO 81 : SEGDES MCHPOI 81 : CALL ECROBJ('CHPOINT',MCHPOI) 82 : RETURN 83 : ENDIF 84 : * 85 : * CAS D'UN CHAMP PAR ELEMENT 86 : * 86 : CALL LIROBJ('MCHAML',MCHEL2,0,IRETOU) 87 : IF (IERR.NE.0) RETURN 88 : IF (IRETOU.NE.0) THEN 89 : SEGINI,MCHELM = MCHEL2 90 : N1 = ICHAML(/1) 91 : DO I = 1,N1 92 : MCHAM1 = ICHAML(I) 93 : SEGINI,MCHAML = MCHAM1 94 : ICHAML(I) = MCHAML 95 : N2 = IELVAL(/1) 96 : 97 : * Vérification que les composantes sont réelles 98 : DO J = 1,N2 99 : IF (TYPCHE(J).NE.'REAL*8') THEN 100 : * Le type %m1:16 de la composante %m17:20 du champ par 101 : * élement %m21:36 ne correspond pas à celui attendu 102 : MOTERR(1:8) = TYPCHE(J) 103 : MOTERR(17:20) = NOMCHE(J) 104 : MOTERR(21:29) = 'argument' 104 : CALL ERREUR(552) 105 : DO K = 1,I 106 : MCHAML = ICHAML(K) 107 : SEGSUP MCHAML 108 : ENDDO 109 : SEGSUP MCHELM 110 : RETURN 111 : ENDIF 112 : ENDDO 113 : 114 : DO J = 1,N2 115 : MELVA1 = IELVAL(J) 116 : SEGINI,MELVAL=MELVA1 117 : IELVAL(J) = MELVAL 118 : N1PTEL = VELCHE(/1) 119 : N1EL = VELCHE(/2) 120 : DO K = 1,N1EL 121 : DO L = 1,N1PTEL 122 : Y = VELCHE(L,K) 123 : IF (ABS(Y).GT.XUN) THEN 124 : IF (ABS(Y).GT.XUNP) THEN 125 : SEGDES,MELVAL,MCHAM1,MCHAML 126 : GOTO 999 127 : ELSE 128 : Y=SIGN(XUN,Y) 129 : ENDIF 130 : ENDIF 131 : IF (IOPT.EQ.1) THEN 132 : VELCHE(L,K) = ACOS(Y) * XRADEG 133 : ELSE 134 : VELCHE(L,K) = ASIN(Y) * XRADEG 135 : ENDIF 136 : ENDDO 137 : ENDDO 138 : SEGDES,MELVAL 139 : ENDDO 140 : SEGDES,MCHAM1 141 : SEGDES,MCHAML 142 : ENDDO 143 : SEGDES MCHELM 143 : CALL ECROBJ('MCHAML' ,MCHELM) 144 : RETURN 145 : ENDIF 146 : 147 : * 148 : * CAS DES LISTREELS 149 : * 150 : IRET1=0 150 : CALL LIROBJ('LISTREEL',IPREE1,0,IRET1) 151 : IF (IERR.NE.0) RETURN 152 : IF (IRET1.EQ.1) THEN 153 : MLREE1=IPREE1 154 : SEGACT,MLREE1 155 : LREE1=MLREE1.PROG(/1) 156 : JG=LREE1 157 : SEGINI,MLREEL 158 : IPREEL=MLREEL 159 : DO IREE=1,JG 160 : Y=MLREE1.PROG(IREE) 161 : IF (ABS(Y).GT.XUN) THEN 162 : IF (ABS(Y).GT.XUNP) THEN 163 : SEGDES,MLREEL,MLREE1 164 : GOTO 999 165 : ELSE 166 : Y=SIGN(XUN,Y) 167 : ENDIF 168 : ENDIF 169 : IF (IOPT.EQ.1) THEN 170 : PROG(IREE)=ACOS(Y)*XRADEG 171 : ELSE 172 : PROG(IREE)=ASIN(Y)*XRADEG 173 : ENDIF 174 : ENDDO 175 : SEGDES,MLREEL,MLREE1 175 : CALL ECROBJ('LISTREEL',IPREEL) 176 : IF (IERR.NE.0) RETURN 177 : RETURN 178 : ENDIF 179 : * 180 : * CAS DES FLOTTANTS 181 : * 181 : CALL LIRREE(Y,0,IRETOU) 182 : IF (IRETOU.EQ.0) GO TO 101 183 : IF (ABS(Y).GT.XUN) THEN 184 : IF (ABS(Y).GT.XUNP) THEN 185 : GOTO 999 186 : ELSE 187 : Y=SIGN(XUN,Y) 188 : ENDIF 189 : ENDIF 190 : * 191 : IF (IOPT.EQ.1) THEN 192 : X = ACOS(Y)*XRADEG 193 : ELSE 194 : X = ASIN(Y)*XRADEG 195 : ENDIF 195 : CALL ECRREE(X) 196 : RETURN 197 : C 198 : C ON N'A DONC RIEN TROUVE POUR FAIRE L'OPERATION 199 : C 200 : 101 CONTINUE 200 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 201 : IF(IRETOU.NE.0) THEN 202 : * Opération non prévue entre un %m1:8 et un %m9:16 202 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 202 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 203 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 203 : CALL ERREUR(532) 204 : ELSE 205 : * Cet opérateur a encore besoin d'un opérande. 205 : CALL ERREUR(533) 206 : ENDIF 207 : RETURN 208 : 209 : 999 CONTINUE 210 : * Nombre inacceptable %r1 211 : REAERR(1) = Y 211 : CALL ERREUR(1009) 212 : RETURN 213 : 214 : END 215 : 216 : 217 : 218 : 219 :
© Cast3M 2003 - All rights reserved.
Disclaimer