Télécharger la plaquette Cast3M


fr en

Télécharger opchpo.eso

Retour à la liste

Numérotation des lignes : 

  1. C OPCHPO    SOURCE    CB215821  16/11/28    21:15:10     9202           
  2.  
  3.       SUBROUTINE OPCHPO(MCHPO1,IEPS,MCHPO2)
  4.  
  5. C=======================================================================
  6. C      N'EFFECTUE PLUS QUE ATAN2 SUR LES CHPOINTS
  7. C  ENTREES
  8. C     IPO1    (E)  POINTEUR SUR UN CHPOINT.
  9. C     IPO2    (E)  POINTEUR SUR UN CHPOINT (2eme ARGUMENT DANS ATAN2)
  10. C     IEPS         = 11 ARCTANGENTE (Seule operation pas encore parallele)
  11. C
  12. C  SORTIES
  13. C     IPO2=POINTEUR SUR LE CHAMPOINT RESULTANT
  14. C
  15. C     CODE EBERSOLT AVRIL 86
  16. C
  17. C=======================================================================
  18.  
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21.  
  22.       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  23.       LOGICAL  BATAN2
  24.       REAL*8   XIN1,XIN2,XOUT
  25.       INTEGER IR
  26.  
  27. -INC CCOPTIO
  28. -INC CCREEL
  29. -INC SMCHPOI
  30. -INC TMTRAV
  31. -INC SMELEME
  32. -INC SMCOORD
  33. C
  34.       BATAN2 = .FALSE.
  35.  
  36.       IR  =0
  37.  
  38.       XIN1=XZERO
  39.       XIN2=XZERO
  40.       XOUT=XZERO/XPI
  41. C
  42.       IF(MCHPO2.NE.0) THEN
  43. C       Calcul de ATAN2 (2 arguments)
  44.         BATAN2 = .TRUE.
  45.         CALL TRACHP(MCHPO1,MTRAV)
  46.         SEGACT MTRAV*MOD
  47.         NNIN=NHAR(/1)
  48.         MCHPOI=MCHPO2
  49.         SEGACT MCHPOI
  50.         SEGINI ICPR
  51.         DO I=1,IGEO(/1)
  52.            ICPR(IGEO(I))=I
  53.         ENDDO
  54.         DO I=1,IPCHP(/1)
  55.           MSOUPO=IPCHP(I)
  56.           SEGACT MSOUPO
  57.           MELEME=IGEOC
  58.           MPOVAL=IPOVAL
  59.           DO 22 J=1,NOCOMP(/2)
  60.             DO K=1,NNIN
  61.               IF(NOCOMP(J).EQ.INCO(K) ) GO TO 24
  62.             ENDDO
  63.             GO TO 22
  64.  
  65.  24         CONTINUE
  66.             SEGACT MELEME,MPOVAL
  67.             DO 25 L=1,NUM(/2)
  68.               IA=ICPR(NUM(1,L))
  69.               IF(IA.EQ.0) GO TO 25
  70.               IBIN(K,IA)=-1
  71.               XIN1=BB(K,IA)
  72.               XIN2=VPOCHA(L,J)
  73.               CALL OPFLOT(XIN1,XIN2,IR,BATAN2,IEPS,XOUT)
  74.               BB(K,IA)= XOUT
  75.  
  76.  25         CONTINUE
  77.             SEGDES MELEME,MPOVAL
  78.  
  79.  22       CONTINUE
  80.           SEGDES MSOUPO
  81.         ENDDO
  82.  
  83.         DO I=1,IGEO(/1)
  84.            DO 27 J=1,NNIN
  85.             IF( IBIN(J,I) .EQ. 0 ) THEN
  86.               GO TO 27
  87.             ELSEIF(IBIN(J,I).EQ.1) THEN
  88.               IF(BB(J,I).GT.REAL(0.D0)) THEN
  89.                 BB(J,I)=REAL(90.D0)
  90.               ELSEIF(BB(J,I).LT.REAL(0.D0)) THEN
  91.                 BB(J,I)=REAL(-90.D0)
  92.               ELSE
  93.                 Y=REAL(0.D0)
  94.                 GOTO 999
  95.               ENDIF
  96.             ELSE
  97.               IBIN(J,I)=1
  98.             ENDIF
  99.  27       CONTINUE
  100.         ENDDO
  101.  
  102.         SEGDES MTRAV
  103.         CALL CRECHP (MTRAV,KSOLU)
  104.         SEGSUP MTRAV
  105.         MCHPO2 = KSOLU
  106.         RETURN
  107.  
  108.       ELSE
  109. C       Ce cas doit passer dans OPCHP1 qui va remplacer OPCHPO lorsque
  110. C       ATAN2 sera realise en parallele
  111.         PRINT *,'Faire  CALL OPCHP1 au lieu de OPCHPO'
  112.         PRINT *,'Please CALL OPCHP1 instead of OPCHPO'
  113.         CALL ERREUR(21)
  114.         RETURN
  115.       ENDIF
  116.  
  117.  999  CONTINUE
  118. C     Nombre inacceptable %r1
  119.       REAERR(1) = Y
  120.       CALL ERREUR(1009)
  121.  
  122.       IF( BATAN2 .EQV. .TRUE. ) THEN
  123.         SEGDES MELEME,MPOVAL
  124.         SEGDES MSOUPO
  125.         SEGSUP MTRAV
  126.       ENDIF
  127.  
  128.       RETURN
  129.  
  130.       END
  131.  
  132.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales