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