C ARCTG     SOURCE    BP208322  13/06/27    21:15:00     7784           
      SUBROUTINE ARCTG
*=============================================================
*
*  ARC-TANGENTE
*
*=============================================================
*
*  Modifications : 
*
*    PM 25/10/2007 : cosmétique léger
*
*=============================================================
*
*  REMARQUES :
*
*=============================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMLREEL
-INC SMCOORD
-INC TMTRAV
-INC SMCHAML
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
      REAL*8 X,Y
      CHARACTER*8 ITYP
      PARAMETER ( EPSI=1.D-30 )

*     Valeurs par défaut de OBJET2
      X=1.D0
      IRCHP1=0
      IRCHP2=0
      IRCHE1=0
      IRET1 =0
      IRET2 =0
*     Un objet de type CHPOINT, ENTIER ou FLOTTANT est attendu.
      CALL MESLIR(-134)

*     Facteur de conversion radian -> degrés
      XRADEG = 180.D0/XPI
*
*     CAS DES CHPOINTS
*
      CALL LIROBJ ('CHPOINT',MCHPO1,0,IRCHP1)
      IF(IRCHP1.NE.0) THEN
         CALL LIROBJ ( 'CHPOINT',MCHPO2,0,IRCHP2)
         IF(IRCHP2.NE.0) THEN
            CALL TRACHP(MCHPO1,MTRAV)
            SEGACT MTRAV*MOD
            NNIN=NHAR(/1)
            MCHPOI=MCHPO2
            SEGACT MCHPOI
            SEGINI ICPR
            DO I=1,IGEO(/1)
               ICPR(IGEO(I))=I
            ENDDO
            DO I=1,IPCHP(/1)
               MSOUPO=IPCHP(I)
               SEGACT MSOUPO
               MELEME=IGEOC
               MPOVAL=IPOVAL
               DO 22 J=1,NOCOMP(/2)
                  DO K=1,NNIN
                     IF(NOCOMP(J).EQ.INCO(K) ) GO TO 24
                  ENDDO
                  GO TO 22
 24               CONTINUE
                  SEGACT MELEME,MPOVAL
                  DO 25 L=1,NUM(/2)
                     IA=ICPR(NUM(1,L))
                     IF(IA.EQ.0) GO TO 25
                     IBIN(K,IA)=-1
                     Y=BB(K,IA)
                     X=VPOCHA(L,J)
                     IF (X.EQ.0.D0.AND.Y.EQ.0.D0) GOTO 999
                     IF(IERR.NE.0) RETURN
                     BB(K,IA)=ATAN2(Y,X)*XRADEG
 25               CONTINUE
                  SEGDES MELEME,MPOVAL
 22            CONTINUE
               SEGDES MSOUPO
            ENDDO
            DO I=1,IGEO(/1)
               DO 27 J=1,NNIN
                  IF(IBIN(J,I).EQ.0) GO TO 27
                  IF(IBIN(J,I).EQ.1) THEN
                     IF(BB(J,I).GT.0.D0) THEN
                        BB(J,I)=90.D0
                     ELSEIF(BB(J,I).LT.0.D0) THEN
                        BB(J,I)=-90.D0
                     ELSE
                        Y=0D0
                        GOTO 999
                     ENDIF
                  ELSE
                     IBIN(J,I)=1
                  ENDIF
 27            CONTINUE
            ENDDO
            SEGDES MTRAV
            CALL CRECHP (MTRAV,KSOLU)
            SEGSUP MTRAV
            CALL ECROBJ('CHPOINT',KSOLU)
            RETURN
         ELSE
            SEGINI,MCHPOI=MCHPO1
            NS=IPCHP(/1)
            DO I = 1,NS
               MSOUP1=IPCHP(I)
               SEGINI,MSOUPO=MSOUP1
               IPCHP(I)=MSOUPO
               IPT1=IGEOC
               SEGINI,IPT2=IPT1
               SEGDES IPT2
               IGEOC=IPT2
               MPOVA1=IPOVAL
               SEGINI,MPOVAL=MPOVA1
               IPOVAL=MPOVAL
               DO K=1,VPOCHA(/2)
                  DO J=1,VPOCHA(/1)
                     Y = VPOCHA(J,K)
                     VPOCHA(J,K)=ATAN2(Y,X)*XRADEG
                  ENDDO
               ENDDO
               SEGDES MPOVAL,MSOUPO
            ENDDO
            SEGDES MCHPOI
            CALL ECROBJ('CHPOINT',MCHPOI)
            RETURN
         ENDIF
      ENDIF
*
*     CAS D'UN CHAMP PAR ELEMENT
*
      CALL LIROBJ('MCHAML',MCHEL2,0,IRCHE1)
      IF (IERR.NE.0) RETURN
      IF (IRCHE1.NE.0) THEN
      
         SEGINI,MCHELM = MCHEL2
         N1 = ICHAML(/1)
         
c        ajout lecture second argument pour ATAN2 au lieu de ATAN
         CALL LIROBJ('MCHAML',MCHEL3,0,IRCHE3)
         IF(IRCHE3.NE.0) THEN
           segact,MCHEL3
           IF (N1.NE.MCHEL3.ICHAML(/1)) GOTO 300
           DO I=1,N1
             IF (IMACHE(I).NE.MCHEL3.IMACHE(I)) GOTO 300
           ENDDO
         ENDIF
         
         DO I = 1,N1
            MCHAM1 = ICHAML(I)
            SEGINI,MCHAML = MCHAM1
            ICHAML(I) = MCHAML
            N2 = IELVAL(/1)
*           Vérif du meme nombre de composante si second argument
            IF(IRCHE3.NE.0) THEN
              MCHAM3 = MCHEL3.ICHAML(I)
              segact,MCHAM3
              IF(MCHAM3.IELVAL(/1).NE.N2) GOTO 302
            ENDIF
*           Vérification que les composantes sont réelles
            DO J = 1,N2
               IF (TYPCHE(J).NE.'REAL*8') THEN
*                 Le type %m1:16 de la composante %m17:20 du champ par
*                 élement %m21:36 ne correspond pas à celui attendu
                  MOTERR(1:8)   = TYPCHE(J)
                  MOTERR(17:20) = NOMCHE(J)
                  MOTERR(21:29) = 'argument'
                  CALL ERREUR(552)
                  DO K = 1,I
                     MCHAML = ICHAML(K)
                     SEGSUP MCHAML
                  ENDDO
                  SEGSUP MCHELM
                  RETURN
               ENDIF
*              Vérification qu'on a la meme chose pour le second argument
               IF(IRCHE3.NE.0) THEN
                 IF(MCHAM3.NOMCHE(J).NE.NOMCHE(J)) GOTO 302
               ENDIF
            ENDDO
*           calcul de l'atan
            DO J = 1,N2
               MELVA1 = IELVAL(J)
               SEGINI,MELVAL=MELVA1
               IELVAL(J) = MELVAL
               NPTEL = VELCHE(/1)
               NEL   = VELCHE(/2)
               IF (IRCHE3.NE.0) THEN
                 MELVA3=MCHAM3.IELVAL(J)
                 segact,MELVA3
                 N3PTEL = MELVA3.VELCHE(/1)
                 N3EL   = MELVA3.VELCHE(/2)
                 IF (NPTEL.EQ.N3PTEL.AND.NEL.EQ.N3EL)THEN
                   DO K = 1,NEL
                     DO L = 1,NPTEL
                       VELCHE(L,K) = XRADEG * 
     &                 ATAN2(VELCHE(L,K),MELVA3.VELCHE(L,K))
                     ENDDO
                   ENDDO
                 ELSE
c                  il faut faire attention aux champs constants
                   N1PTEL = max(NPTEL,N3PTEL)
                   N1EL   = max(NEL,  N3EL)
                   segadj,MELVAL
                   segact,MELVA1
                   DO K1 = 1,N1EL
                     K  = MIN(K1,NEL)
                     K3 = MIN(K3,N3EL)
                     DO L1 = 1,N1PTEL
                       L  = MIN(L1,NPTEL)
                       L3 = MIN(L1,NP3TEL)
                       VELCHE(L1,K1) = XRADEG * 
     &                 ATAN2(MELVA1.VELCHE(L,K),MELVA3.VELCHE(L3,K3))
                     ENDDO
                   ENDDO
                   segdes,MELVA1
                 ENDIF
                 SEGDES,MELVA3
               ELSE
                 DO K = 1,NEL
                  DO L = 1,NPTEL
                     VELCHE(L,K) = XRADEG * ATAN(VELCHE(L,K))
                  ENDDO
                 ENDDO
               ENDIF
               SEGDES,MELVAL
            ENDDO
            SEGDES,MCHAM1
            SEGDES,MCHAML
         ENDDO
         
         SEGDES MCHELM
         CALL ECROBJ('MCHAML' ,MCHELM)
         RETURN
         
c        gestion des erreurs
         goto 301
 302     CALL ERREUR(488)       
 301     DO K = 1,I
            MCHAML = ICHAML(K)
            SEGSUP MCHAML
            MCHAM3 = MCHEL3.ICHAML(K)
            segdes,MCHAM3
         ENDDO
         goto 299
 300     CALL ERREUR(329)
 299     segdes,MCHEL3,MCHEL2
         segsup,MCHELM         
         RETURN                
      ENDIF

*
*     CAS DES LISTREELS
*
      IRET1=0
      CALL LIROBJ('LISTREEL',IPREE1,0,IRET1)
      IF (IERR.NE.0) RETURN
      IF (IRET1.EQ.1) THEN
         CALL LIROBJ('LISTREEL',IPREE2,0,IRET2)
         IF (IERR.NE.0) RETURN
         MLREE1=IPREE1
         SEGACT,MLREE1
         LREE1=MLREE1.PROG(/1)
         IF (IRET2.NE.0) THEN
            MLREE2=IPREE2
            SEGACT,MLREE2
            LREE2=MLREE2.PROG(/1)
            IF (LREE1.NE.LREE2) THEN
               CALL ERREUR(21)
               SEGDES,MLREE1,MLREE2
               RETURN
            ENDIF
         ENDIF
         JG=LREE1
         SEGINI,MLREEL
         IPREEL=MLREEL
         DO IREE=1,JG
            Y=MLREE1.PROG(IREE)
            IF (IRET2.EQ.0) THEN
               X=1.D0
            ELSE
               X=MLREE2.PROG(IREE)
            ENDIF
            IF (ABS(X).LT.EPSI.AND.ABS(Y).LT.EPSI) THEN 
               SEGDES,MLREE1
               IF (IRET2.NE.0) SEGDES,MLREE2
               SEGSUP,MLREEL
               GOTO 999
            ENDIF
            PROG(IREE)=ATAN2(Y,X)*XRADEG
         ENDDO
         SEGDES,MLREEL,MLREE1
         IF (IRET2.NE.0) SEGDES,MLREE2
         CALL ECROBJ('LISTREEL',IPREEL)
         IF (IERR.NE.0) RETURN
         RETURN
      ENDIF
*
*     CAS DES FLOTTANTS
*
      CALL LIRREE(Y,0,IRFLO1)
      IF(IRFLO1.EQ.0) GO TO 101
      X=1.D0
      CALL LIRREE(X,0,IRFLO2)
      IF (X.EQ.0.D0.AND.Y.EQ.0.D0) GOTO 999
      IF (IERR.NE.0) RETURN
      CALL ECRREE(ATAN2(Y,X)*XRADEG)
      RETURN
C
C     ON N'A DONC RIEN TROUVE POUR FAIRE L'OPERATION
C
 101  CONTINUE
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
*        Opération non prévue entre un %m1:8 et un %m9:16
         CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
         CALL QUETYP(MOTERR(9:16),0,IRETOU)
         IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
         CALL ERREUR(532)
      ELSE
*        Cet opérateur a encore besoin d'un opérande.
         CALL ERREUR(533)
      ENDIF
      RETURN

C
C     ERREUR ATG(0/0)=?
C
 999  CONTINUE
*     Nombre inacceptable %r1
      REAERR(1) = Y
      CALL ERREUR(1009)

c       write(6,*) 'DESACTIVATION a suivre ...',IRCHP1,IRCHP2,IRET1,IRET2     
*     DESACTIVATION SELON TYPE D OBJET pouvant aboutir ici ...
*    -chpoints
      IF(IRCHP1.NE.0) then
         IF(IRCHP2.NE.0) THEN
            SEGDES MELEME,MPOVAL
            SEGDES MSOUPO
            SEGSUP MTRAV
*         ELSE on n a pas de raison d arriver ici
         ENDIF
      ENDIF
*    -les MCHAML et FLOTTANTS n'arrivent pas ici non plus    
*    -LISTREELS    
      IF(IRET1.NE.0)  SEGDES,MLREE1
      IF(IRET2.NE.0)  SEGDES,MLREE2
      RETURN

      END