1 : C ARCTG SOURCE BP208322 13/06/27 21:15:00 7784 2 : SUBROUTINE ARCTG 3 : *============================================================= 4 : * 5 : * ARC-TANGENTE 6 : * 7 : *============================================================= 8 : * 9 : * Modifications : 10 : * 11 : * PM 25/10/2007 : cosmétique léger 12 : * 13 : *============================================================= 14 : * 15 : * REMARQUES : 16 : * 17 : *============================================================= 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8 (A-H,O-Z) 20 : -INC CCREEL 21 : -INC CCOPTIO 22 : -INC SMCHPOI 23 : -INC SMELEME 24 : -INC SMLREEL 25 : -INC SMCOORD 26 : -INC TMTRAV 27 : -INC SMCHAML 28 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 29 : REAL*8 X,Y 30 : CHARACTER*8 ITYP 31 : PARAMETER ( EPSI=1.D-30 ) 32 : 33 : * Valeurs par défaut de OBJET2 34 : X=1.D0 35 : IRCHP1=0 36 : IRCHP2=0 37 : IRCHE1=0 38 : IRET1 =0 39 : IRET2 =0 40 : * Un objet de type CHPOINT, ENTIER ou FLOTTANT est attendu. 40 : CALL MESLIR(-134) 41 : 42 : * Facteur de conversion radian -> degrés 43 : XRADEG = 180.D0/XPI 44 : * 45 : * CAS DES CHPOINTS 46 : * 46 : CALL LIROBJ ('CHPOINT',MCHPO1,0,IRCHP1) 47 : IF(IRCHP1.NE.0) THEN 47 : CALL LIROBJ ( 'CHPOINT',MCHPO2,0,IRCHP2) 48 : IF(IRCHP2.NE.0) THEN 48 : CALL TRACHP(MCHPO1,MTRAV) 49 : SEGACT MTRAV*MOD 50 : NNIN=NHAR(/1) 51 : MCHPOI=MCHPO2 52 : SEGACT MCHPOI 53 : SEGINI ICPR 54 : DO I=1,IGEO(/1) 55 : ICPR(IGEO(I))=I 56 : ENDDO 57 : DO I=1,IPCHP(/1) 58 : MSOUPO=IPCHP(I) 59 : SEGACT MSOUPO 60 : MELEME=IGEOC 61 : MPOVAL=IPOVAL 62 : DO 22 J=1,NOCOMP(/2) 63 : DO K=1,NNIN 64 : IF(NOCOMP(J).EQ.INCO(K) ) GO TO 24 65 : ENDDO 66 : GO TO 22 67 : 24 CONTINUE 68 : SEGACT MELEME,MPOVAL 69 : DO 25 L=1,NUM(/2) 70 : IA=ICPR(NUM(1,L)) 71 : IF(IA.EQ.0) GO TO 25 72 : IBIN(K,IA)=-1 73 : Y=BB(K,IA) 74 : X=VPOCHA(L,J) 75 : IF (X.EQ.0.D0.AND.Y.EQ.0.D0) GOTO 999 76 : IF(IERR.NE.0) RETURN 77 : BB(K,IA)=ATAN2(Y,X)*XRADEG 78 : 25 CONTINUE 79 : SEGDES MELEME,MPOVAL 80 : 22 CONTINUE 81 : SEGDES MSOUPO 82 : ENDDO 83 : DO I=1,IGEO(/1) 84 : DO 27 J=1,NNIN 85 : IF(IBIN(J,I).EQ.0) GO TO 27 86 : IF(IBIN(J,I).EQ.1) THEN 87 : IF(BB(J,I).GT.0.D0) THEN 88 : BB(J,I)=90.D0 89 : ELSEIF(BB(J,I).LT.0.D0) THEN 90 : BB(J,I)=-90.D0 91 : ELSE 92 : Y=0D0 93 : GOTO 999 94 : ENDIF 95 : ELSE 96 : IBIN(J,I)=1 97 : ENDIF 98 : 27 CONTINUE 99 : ENDDO 100 : SEGDES MTRAV 100 : CALL CRECHP (MTRAV,KSOLU) 101 : SEGSUP MTRAV 101 : CALL ECROBJ('CHPOINT',KSOLU) 102 : RETURN 103 : ELSE 104 : SEGINI,MCHPOI=MCHPO1 105 : NS=IPCHP(/1) 106 : DO I = 1,NS 107 : MSOUP1=IPCHP(I) 108 : SEGINI,MSOUPO=MSOUP1 109 : IPCHP(I)=MSOUPO 110 : IPT1=IGEOC 111 : SEGINI,IPT2=IPT1 112 : SEGDES IPT2 113 : IGEOC=IPT2 114 : MPOVA1=IPOVAL 115 : SEGINI,MPOVAL=MPOVA1 116 : IPOVAL=MPOVAL 117 : DO K=1,VPOCHA(/2) 118 : DO J=1,VPOCHA(/1) 119 : Y = VPOCHA(J,K) 120 : VPOCHA(J,K)=ATAN2(Y,X)*XRADEG 121 : ENDDO 122 : ENDDO 123 : SEGDES MPOVAL,MSOUPO 124 : ENDDO 125 : SEGDES MCHPOI 125 : CALL ECROBJ('CHPOINT',MCHPOI) 126 : RETURN 127 : ENDIF 128 : ENDIF 129 : * 130 : * CAS D'UN CHAMP PAR ELEMENT 131 : * 131 : CALL LIROBJ('MCHAML',MCHEL2,0,IRCHE1) 132 : IF (IERR.NE.0) RETURN 133 : IF (IRCHE1.NE.0) THEN 134 : 135 : SEGINI,MCHELM = MCHEL2 136 : N1 = ICHAML(/1) 137 : 138 : c ajout lecture second argument pour ATAN2 au lieu de ATAN 138 : CALL LIROBJ('MCHAML',MCHEL3,0,IRCHE3) 139 : IF(IRCHE3.NE.0) THEN 140 : segact,MCHEL3 141 : IF (N1.NE.MCHEL3.ICHAML(/1)) GOTO 300 142 : DO I=1,N1 143 : IF (IMACHE(I).NE.MCHEL3.IMACHE(I)) GOTO 300 144 : ENDDO 145 : ENDIF 146 : 147 : DO I = 1,N1 148 : MCHAM1 = ICHAML(I) 149 : SEGINI,MCHAML = MCHAM1 150 : ICHAML(I) = MCHAML 151 : N2 = IELVAL(/1) 152 : * Vérif du meme nombre de composante si second argument 153 : IF(IRCHE3.NE.0) THEN 154 : MCHAM3 = MCHEL3.ICHAML(I) 155 : segact,MCHAM3 156 : IF(MCHAM3.IELVAL(/1).NE.N2) GOTO 302 157 : ENDIF 158 : * Vérification que les composantes sont réelles 159 : DO J = 1,N2 160 : IF (TYPCHE(J).NE.'REAL*8') THEN 161 : * Le type %m1:16 de la composante %m17:20 du champ par 162 : * élement %m21:36 ne correspond pas à celui attendu 163 : MOTERR(1:8) = TYPCHE(J) 164 : MOTERR(17:20) = NOMCHE(J) 165 : MOTERR(21:29) = 'argument' 165 : CALL ERREUR(552) 166 : DO K = 1,I 167 : MCHAML = ICHAML(K) 168 : SEGSUP MCHAML 169 : ENDDO 170 : SEGSUP MCHELM 171 : RETURN 172 : ENDIF 173 : * Vérification qu'on a la meme chose pour le second argument 174 : IF(IRCHE3.NE.0) THEN 175 : IF(MCHAM3.NOMCHE(J).NE.NOMCHE(J)) GOTO 302 176 : ENDIF 177 : ENDDO 178 : * calcul de l'atan 179 : DO J = 1,N2 180 : MELVA1 = IELVAL(J) 181 : SEGINI,MELVAL=MELVA1 182 : IELVAL(J) = MELVAL 183 : NPTEL = VELCHE(/1) 184 : NEL = VELCHE(/2) 185 : IF (IRCHE3.NE.0) THEN 186 : MELVA3=MCHAM3.IELVAL(J) 187 : segact,MELVA3 188 : N3PTEL = MELVA3.VELCHE(/1) 189 : N3EL = MELVA3.VELCHE(/2) 190 : IF (NPTEL.EQ.N3PTEL.AND.NEL.EQ.N3EL)THEN 191 : DO K = 1,NEL 192 : DO L = 1,NPTEL 193 : VELCHE(L,K) = XRADEG * 194 : & ATAN2(VELCHE(L,K),MELVA3.VELCHE(L,K)) 195 : ENDDO 196 : ENDDO 197 : ELSE 198 : c il faut faire attention aux champs constants 199 : N1PTEL = max(NPTEL,N3PTEL) 200 : N1EL = max(NEL, N3EL) 201 : segadj,MELVAL 202 : segact,MELVA1 203 : DO K1 = 1,N1EL 204 : K = MIN(K1,NEL) 205 : K3 = MIN(K3,N3EL) 206 : DO L1 = 1,N1PTEL 207 : L = MIN(L1,NPTEL) 208 : L3 = MIN(L1,NP3TEL) 209 : VELCHE(L1,K1) = XRADEG * 210 : & ATAN2(MELVA1.VELCHE(L,K),MELVA3.VELCHE(L3,K3)) 211 : ENDDO 212 : ENDDO 213 : segdes,MELVA1 214 : ENDIF 215 : SEGDES,MELVA3 216 : ELSE 217 : DO K = 1,NEL 218 : DO L = 1,NPTEL 219 : VELCHE(L,K) = XRADEG * ATAN(VELCHE(L,K)) 220 : ENDDO 221 : ENDDO 222 : ENDIF 223 : SEGDES,MELVAL 224 : ENDDO 225 : SEGDES,MCHAM1 226 : SEGDES,MCHAML 227 : ENDDO 228 : 229 : SEGDES MCHELM 229 : CALL ECROBJ('MCHAML' ,MCHELM) 230 : RETURN 231 : 232 : c gestion des erreurs 233 : goto 301 233 : 302 CALL ERREUR(488) 234 : 301 DO K = 1,I 235 : MCHAML = ICHAML(K) 236 : SEGSUP MCHAML 237 : MCHAM3 = MCHEL3.ICHAML(K) 238 : segdes,MCHAM3 239 : ENDDO 240 : goto 299 240 : 300 CALL ERREUR(329) 241 : 299 segdes,MCHEL3,MCHEL2 242 : segsup,MCHELM 243 : RETURN 244 : ENDIF 245 : 246 : * 247 : * CAS DES LISTREELS 248 : * 249 : IRET1=0 249 : CALL LIROBJ('LISTREEL',IPREE1,0,IRET1) 250 : IF (IERR.NE.0) RETURN 251 : IF (IRET1.EQ.1) THEN 251 : CALL LIROBJ('LISTREEL',IPREE2,0,IRET2) 252 : IF (IERR.NE.0) RETURN 253 : MLREE1=IPREE1 254 : SEGACT,MLREE1 255 : LREE1=MLREE1.PROG(/1) 256 : IF (IRET2.NE.0) THEN 257 : MLREE2=IPREE2 258 : SEGACT,MLREE2 259 : LREE2=MLREE2.PROG(/1) 260 : IF (LREE1.NE.LREE2) THEN 260 : CALL ERREUR(21) 261 : SEGDES,MLREE1,MLREE2 262 : RETURN 263 : ENDIF 264 : ENDIF 265 : JG=LREE1 266 : SEGINI,MLREEL 267 : IPREEL=MLREEL 268 : DO IREE=1,JG 269 : Y=MLREE1.PROG(IREE) 270 : IF (IRET2.EQ.0) THEN 271 : X=1.D0 272 : ELSE 273 : X=MLREE2.PROG(IREE) 274 : ENDIF 275 : IF (ABS(X).LT.EPSI.AND.ABS(Y).LT.EPSI) THEN 276 : SEGDES,MLREE1 277 : IF (IRET2.NE.0) SEGDES,MLREE2 278 : SEGSUP,MLREEL 279 : GOTO 999 280 : ENDIF 281 : PROG(IREE)=ATAN2(Y,X)*XRADEG 282 : ENDDO 283 : SEGDES,MLREEL,MLREE1 284 : IF (IRET2.NE.0) SEGDES,MLREE2 284 : CALL ECROBJ('LISTREEL',IPREEL) 285 : IF (IERR.NE.0) RETURN 286 : RETURN 287 : ENDIF 288 : * 289 : * CAS DES FLOTTANTS 290 : * 290 : CALL LIRREE(Y,0,IRFLO1) 291 : IF(IRFLO1.EQ.0) GO TO 101 292 : X=1.D0 292 : CALL LIRREE(X,0,IRFLO2) 293 : IF (X.EQ.0.D0.AND.Y.EQ.0.D0) GOTO 999 294 : IF (IERR.NE.0) RETURN 294 : CALL ECRREE(ATAN2(Y,X)*XRADEG) 295 : RETURN 296 : C 297 : C ON N'A DONC RIEN TROUVE POUR FAIRE L'OPERATION 298 : C 299 : 101 CONTINUE 299 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 300 : IF(IRETOU.NE.0) THEN 301 : * Opération non prévue entre un %m1:8 et un %m9:16 301 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 301 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 302 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 302 : CALL ERREUR(532) 303 : ELSE 304 : * Cet opérateur a encore besoin d'un opérande. 304 : CALL ERREUR(533) 305 : ENDIF 306 : RETURN 307 : 308 : C 309 : C ERREUR ATG(0/0)=? 310 : C 311 : 999 CONTINUE 312 : * Nombre inacceptable %r1 313 : REAERR(1) = Y 313 : CALL ERREUR(1009) 314 : 315 : c write(6,*) 'DESACTIVATION a suivre ...',IRCHP1,IRCHP2,IRET1,IRET2 316 : * DESACTIVATION SELON TYPE D OBJET pouvant aboutir ici ... 317 : * -chpoints 318 : IF(IRCHP1.NE.0) then 319 : IF(IRCHP2.NE.0) THEN 320 : SEGDES MELEME,MPOVAL 321 : SEGDES MSOUPO 322 : SEGSUP MTRAV 323 : * ELSE on n a pas de raison d arriver ici 324 : ENDIF 325 : ENDIF 326 : * -les MCHAML et FLOTTANTS n'arrivent pas ici non plus 327 : * -LISTREELS 328 : IF(IRET1.NE.0) SEGDES,MLREE1 329 : IF(IRET2.NE.0) SEGDES,MLREE2 330 : RETURN 331 : 332 : END 333 : 334 : 335 : 336 : 337 : 338 : 339 :
© Cast3M 2003 - All rights reserved.
Disclaimer