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