Télécharger la plaquette Cast3M


fr en

Télécharger prosca.eso

Retour à la liste

Numérotation des lignes : 

prosca

  1. C PROSCA    SOURCE    CB215821  20/11/25    13:37:31     10792          
  2.       SUBROUTINE PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET)
  3. C-----------------------------------------------------------------------
  4. C                 PRODUIT SCALAIRE DE 2 CHPOINTS
  5. C-----------------------------------------------------------------------
  6. C    EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0
  7. C    EN SERIE DE FOURIER , IL EST TYPE NOHARM
  8. C-----------------------------------------------------------------------
  9. C  ENTREE
  10. C     IPOI1   CHPOINT
  11. C     IPOI2   CHPOINT
  12. C     MLMOTX  LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER  CHPOINT
  13. C     MLMOTY  LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHPOINT
  14. C  SORTIE
  15. C     IRET    POINTEUR SUR LE CHPOINT RESULTAT
  16. C-----------------------------------------------------------------------
  17.  
  18.       IMPLICIT INTEGER(I-N)
  19.       IMPLICIT REAL*8(A-H,O-Z)
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMCHPOI
  24. -INC SMLMOTS
  25. -INC SMELEME
  26. -INC SMCOORD
  27. -INC TMTRAV
  28.  
  29.       CHARACTER*(LOCOMP) NOIN
  30.  
  31.       CHARACTER*4 NOMIL
  32.       integer*4   iomil
  33.       equivalence (nomil,iomil)
  34.       DATA NOMIL/'NOHA'/
  35.  
  36.       SEGMENT ITRAV
  37.         REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI)
  38.         INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI)
  39.         CHARACTER*(LOCOMP) INCA(NINC),INCB(NINC)
  40.       ENDSEGMENT
  41.  
  42.       NPOI=nbpts
  43.       MLMOTS=MLMOTX
  44.       SEGACT MLMOTS
  45.       NINC= MOTS(/2)
  46.       SEGINI ITRAV
  47.       DO 1 I = 1, NINC
  48.       INCA(I)=MOTS(I)
  49.   1   CONTINUE
  50.       MLMOTS=MLMOTY
  51.       SEGACT MLMOTS
  52.       IF(MOTS(/2).NE.NINC) THEN
  53.       SEGSUP ITRAV
  54.       MOTERR(1:4)='PSCA'
  55.       MOTERR(5:12)='LISTMOTS'
  56.       CALL ERREUR(125)
  57.       RETURN
  58.       ENDIF
  59.       DO 21 I = 1, NINC
  60.       INCB(I)=MOTS(I)
  61.  21   CONTINUE
  62. C
  63. C *********  IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB
  64. C *********  CREATION D'ABORD DE IVAA PUIS DE IVAB
  65. C
  66.       MCHPOI=MCHPO1
  67.       SEGACT MCHPOI
  68.       NSOUPO = IPCHP(/1)
  69.       DO 2 M = 1,NSOUPO
  70.       MSOUPO = IPCHP(M)
  71.       SEGACT MSOUPO
  72.       NC=NOCOMP(/2)
  73.       DO 10 I = 1,NINC
  74.   10  IPOS(I)=0
  75.       DO 4 K = 1, NINC
  76.       DO 3 J = 1, NC
  77.        NOIN= NOCOMP (J)
  78.       IF(INCA(K). EQ . NOIN) THEN
  79.          IPOS(K)=J
  80.          GO TO 4
  81.       ENDIF
  82.    3  CONTINUE
  83.    4  CONTINUE
  84.       DO 5 I = 1,NINC
  85.       IF(IPOS(I). NE . 0) GO TO 6
  86.    5  CONTINUE
  87.       GO TO 8
  88.    6  CONTINUE
  89.       MELEME=IGEOC
  90.       SEGACT MELEME
  91.       NBELEM=NUM(/2)
  92.       MPOVAL=IPOVAL
  93.       SEGACT MPOVAL
  94.       DO 9 LI = 1,NINC
  95.       KL = IPOS(LI)
  96.       IF(KL.EQ.0) GO TO 9
  97.       DO 7 I = 1,NBELEM
  98.       I1 = NUM(1,I)
  99.       IVAA(LI,I1)=VPOCHA(I,KL)
  100.       ICPRA(I1)=1
  101.     7 CONTINUE
  102.     9 CONTINUE
  103.     8 CONTINUE
  104.     2 CONTINUE
  105. C
  106. C     TRAITEMENT DU 2-EME CHPOINT
  107. C
  108.       IA=0
  109.       MCHPOI=MCHPO2
  110.       SEGACT MCHPOI
  111.       NSOUPO = IPCHP(/1)
  112.       DO 12 M = 1,NSOUPO
  113.       MSOUPO = IPCHP(M)
  114.       SEGACT MSOUPO
  115.       NC=NOCOMP(/2)
  116.       DO 11 I = 1,NINC
  117.   11  IPOS(I)=0
  118.       DO 14  K= 1,NINC
  119.       DO 13  J = 1, NC
  120.       NOIN= NOCOMP (J)
  121.       IF(INCB(K). EQ . NOIN) THEN
  122.          IPOS(K)=J
  123.          GO TO 14
  124.       ENDIF
  125.   13  CONTINUE
  126.   14  CONTINUE
  127.       DO 15 I = 1,NINC
  128.       IF(IPOS(I). NE . 0) GO TO 16
  129.   15  CONTINUE
  130.       GO TO 18
  131.   16  CONTINUE
  132.       MELEME=IGEOC
  133.       SEGACT MELEME
  134.       NBELEM=NUM(/2)
  135.       MPOVAL=IPOVAL
  136.       SEGACT MPOVAL
  137.       DO 19 LI = 1,NINC
  138.       KL = IPOS(LI)
  139.       IF(KL.EQ.0) GO TO 19
  140.       DO 17 I = 1,NBELEM
  141.       I1 = NUM(1,I)
  142.       IVAB(LI,I1)=VPOCHA(I,KL)
  143.       IF(ICPRA(I1).NE.0) THEN
  144.       IA=IA+1
  145.       ICPRB(I1)=IA
  146.       ENDIF
  147.    17 CONTINUE
  148.    19 CONTINUE
  149.    18 CONTINUE
  150.    12 CONTINUE
  151.       IF(IA.EQ.0) THEN
  152. C
  153. C     CHPOINT VIDE
  154. C
  155.       SEGSUP ITRAV
  156.       NSOUPO=0
  157.       NAT=1
  158.       SEGINI MCHPOI
  159.       IFOPOI=IFOUR
  160.       IRET=MCHPOI
  161.       RETURN
  162.       ENDIF
  163. C
  164. C     ON EFFECTUE LE CALCUL
  165. C
  166.       NNIN=1
  167.       NNNOE=IA
  168.       SEGINI MTRAV
  169.       INCO(1)='SCAL'
  170. *
  171. *  MODIF  MILL LE 18 / 7 / 90
  172. *  REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
  173. *
  174.       NHMIL=iomil
  175.       IF(IFOPOI.EQ.1) THEN
  176.       NHAR(1)=NHMIL
  177.       ELSE
  178.       NHAR(1)=0
  179.       ENDIF
  180. *
  181.       MCHPOI=MCHPO1
  182.       SEGACT MCHPOI
  183.       NSOUPO=IPCHP(/1)
  184.       DO 22 M=1,NSOUPO
  185.         MSOUPO=IPCHP(M)
  186.         SEGACT MSOUPO
  187.         MELEME=IGEOC
  188.         SEGACT MELEME
  189.         DO 27 J=1,NUM(/2)
  190.           I1=NUM(1,J)
  191.           IB=ICPRB(I1)
  192.           IF(IB.EQ.0) GO TO 27
  193.           IF(IGEO(IB).NE.0) GO TO 27
  194.           IGEO(IB)=I1
  195.           IBIN(1,IB)=1
  196.           DO 28 LI=1,NINC
  197.             BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1)
  198.   28      CONTINUE
  199.   27    CONTINUE
  200.   22  CONTINUE
  201.       SEGSUP ITRAV
  202.       CALL CRECHP(MTRAV,IRET)
  203.       SEGSUP MTRAV
  204.       END
  205.  
  206.  
  207.  
  208.  
  209.  

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