Sources Esope | Cast3M

opchpo
C OPCHPO    SOURCE    CB215821  23/10/18    21:15:07     11760          
 
      SUBROUTINE OPCHPO(MCHPO1,IOPERA,MCHPO2)
 
C=======================================================================
C      N'EFFECTUE PLUS QUE ATAN2 SUR LES CHPOINTS
C  ENTREES
C     IPO1    (E)  POINTEUR SUR UN CHPOINT.
C     IPO2    (E)  POINTEUR SUR UN CHPOINT (2eme ARGUMENT DANS ATAN2)
C     IOPERA  (E)  = 11 ARCTANGENTE (Seule operation pas encore parallele)
C
C  SORTIES
C     IPO2=POINTEUR SUR LE CHAMPOINT RESULTANT
C
C     CODE EBERSOLT AVRIL 86
C
C=======================================================================
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
      SEGMENT ICPR(nbpts)
      LOGICAL  BATAN2
      REAL*8   XIN1,XIN2,XOUT
      REAL*8   XVAL(3)
 
      INTEGER IR
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCHPOI
-INC TMTRAV
-INC SMELEME
-INC SMCOORD
C
      BATAN2 = .FALSE.
 
      IR    = 0
      MTRAV = 0
 
      XIN1=XZERO
      XIN2=XZERO
      XOUT=XZERO/XPI
C
      IF(MCHPO2.NE.0) THEN
C       Calcul de ATAN2 (2 arguments)
        BATAN2 = .TRUE.
        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
              XIN1=BB(K,IA)
              XIN2=VPOCHA(L,J)
 
              NN0  = 1
              XVAL(1)=XIN1
              XVAL(2)=XIN2
              CALL OPTABJ(1 ,0,IOPERA,2,
     &                  XVAL(1),XVAL(2),XVAL(3),
     &                  NN0  ,NN0  ,NN0  ,0 ,0  ,0.D0 ,IRETOU)
              BB(K,IA)= XVAL(3)
 25         CONTINUE
 
 22       CONTINUE
        ENDDO
 
        DO I=1,IGEO(/1)
           DO 27 J=1,NNIN
            IF( IBIN(J,I) .EQ. 0 ) THEN
              GO TO 27
            ELSEIF(IBIN(J,I).EQ.1) THEN
              IF(BB(J,I).GT.REAL(0.D0)) THEN
                BB(J,I)=REAL(90.D0)
              ELSEIF(BB(J,I).LT.REAL(0.D0)) THEN
                BB(J,I)=REAL(-90.D0)
              ELSE
                Y=REAL(0.D0)
                GOTO 999
              ENDIF
            ELSE
              IBIN(J,I)=1
            ENDIF
 27       CONTINUE
        ENDDO
 
        CALL CRECHP (MTRAV,KSOLU)
        SEGSUP MTRAV
        MCHPO2 = KSOLU
        RETURN
 
      ELSE
C       Ce cas doit passer dans OPCHP1 qui va remplacer OPCHPO lorsque
C       ATAN2 sera realise en parallele
        PRINT *,'Faire  CALL OPCHP1 au lieu de OPCHPO'
        PRINT *,'Please CALL OPCHP1 instead of OPCHPO'
        CALL ERREUR(21)
        RETURN
      ENDIF
 
 999  CONTINUE
C     Nombre inacceptable %r1
      REAERR(1) = Y
      CALL ERREUR(1009)
      IF(MTRAV .NE. 0) SEGSUP,MTRAV
      RETURN
 
      END