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    GOUNAND   25/11/12    21:15:42     12399          
  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.             IPOS(I)=0
  75.  10      CONTINUE
  76.          DO 4 K = 1, NINC
  77.             DO 3 J = 1, NC
  78.                NOIN= NOCOMP (J)
  79.                IF(INCA(K). EQ . NOIN) THEN
  80.                   IPOS(K)=J
  81.                   GO TO 4
  82.                ENDIF
  83.  3          CONTINUE
  84.  4       CONTINUE
  85.          DO 5 I = 1,NINC
  86.             IF(IPOS(I). NE . 0) GO TO 6
  87.  5       CONTINUE
  88.          GO TO 8
  89.  6       CONTINUE
  90.          MELEME=IGEOC
  91.          SEGACT MELEME
  92.          NBELEM=NUM(/2)
  93.          MPOVAL=IPOVAL
  94.          SEGACT MPOVAL
  95.          DO 9 LI = 1,NINC
  96.             KL = IPOS(LI)
  97.             IF(KL.EQ.0) GO TO 9
  98.             DO 7 I = 1,NBELEM
  99.                I1 = NUM(1,I)
  100.                IVAA(LI,I1)=VPOCHA(I,KL)
  101.                ICPRA(I1)=1
  102.  7          CONTINUE
  103.  9       CONTINUE
  104.  8       CONTINUE
  105.     2 CONTINUE
  106. C
  107. C     TRAITEMENT DU 2-EME CHPOINT
  108. C
  109.       IA=0
  110.       MCHPOI=MCHPO2
  111.       SEGACT MCHPOI
  112.       NSOUPO = IPCHP(/1)
  113.       DO 12 M = 1,NSOUPO
  114.          MSOUPO = IPCHP(M)
  115.          SEGACT MSOUPO
  116.          NC=NOCOMP(/2)
  117.          DO 11 I = 1,NINC
  118.             IPOS(I)=0
  119.  11      CONTINUE
  120.          DO 14  K= 1,NINC
  121.             DO 13  J = 1, NC
  122.                NOIN= NOCOMP (J)
  123.                IF(INCB(K). EQ . NOIN) THEN
  124.                   IPOS(K)=J
  125.                   GO TO 14
  126.                ENDIF
  127.  13         CONTINUE
  128.  14      CONTINUE
  129.          DO 15 I = 1,NINC
  130.             IF(IPOS(I). NE . 0) GO TO 16
  131.  15      CONTINUE
  132.          GO TO 18
  133.  16      CONTINUE
  134.          MELEME=IGEOC
  135.          SEGACT MELEME
  136.          NBELEM=NUM(/2)
  137.          MPOVAL=IPOVAL
  138.          SEGACT MPOVAL
  139.          DO 19 LI = 1,NINC
  140.             KL = IPOS(LI)
  141.             IF(KL.EQ.0) GO TO 19
  142.             DO 17 I = 1,NBELEM
  143.                I1 = NUM(1,I)
  144.                IVAB(LI,I1)=VPOCHA(I,KL)
  145.                IF(ICPRA(I1).NE.0) THEN
  146.                   IA=IA+1
  147.                   ICPRB(I1)=IA
  148.                ENDIF
  149.  17         CONTINUE
  150.  19      CONTINUE
  151.  18      CONTINUE
  152.  12   CONTINUE
  153. *
  154.       CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
  155.       IF(IA.EQ.0) THEN
  156. C
  157. C     CHPOINT VIDE
  158. C
  159.       SEGSUP ITRAV
  160.       NSOUPO=0
  161.       NAT=1
  162.       SEGINI MCHPOI
  163.       IFOPOI=IFOUR
  164.       IF (INAT.GE.1) JATTRI(1)=IATTR
  165.       IRET=MCHPOI
  166.       RETURN
  167.       ENDIF
  168. C
  169. C     ON EFFECTUE LE CALCUL
  170. C
  171.       NNIN=1
  172.       NNNOE=IA
  173.       SEGINI MTRAV
  174.       INCO(1)='SCAL'
  175. *
  176. *  MODIF  MILL LE 18 / 7 / 90
  177. *  REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
  178. *
  179.       NHMIL=iomil
  180.       IF(IFOPOI.EQ.1) THEN
  181.       NHAR(1)=NHMIL
  182.       ELSE
  183.       NHAR(1)=0
  184.       ENDIF
  185. *
  186.       MCHPOI=MCHPO1
  187.       SEGACT MCHPOI
  188.       NSOUPO=IPCHP(/1)
  189.       DO 22 M=1,NSOUPO
  190.         MSOUPO=IPCHP(M)
  191.         SEGACT MSOUPO
  192.         MELEME=IGEOC
  193.         SEGACT MELEME
  194.         DO 27 J=1,NUM(/2)
  195.           I1=NUM(1,J)
  196.           IB=ICPRB(I1)
  197.           IF(IB.EQ.0) GO TO 27
  198.           IF(IGEO(IB).NE.0) GO TO 27
  199.           IGEO(IB)=I1
  200.           IBIN(1,IB)=1
  201.           DO 28 LI=1,NINC
  202.             BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1)
  203.   28      CONTINUE
  204.   27    CONTINUE
  205.   22  CONTINUE
  206.       SEGSUP ITRAV
  207.       CALL CRECHP(MTRAV,IRET)
  208.       SEGSUP MTRAV
  209.       MCHPOI=IRET
  210.       SEGACT MCHPOI*MOD
  211.       NAT=INAT
  212.       NSOUPO=IPCHP(/1)
  213.       SEGADJ,MCHPOI
  214.       JATTRI(1)=IATTR
  215.       RETURN
  216.       END
  217.  
  218.  

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