Télécharger la plaquette Cast3M


fr en

Télécharger provcc.eso

Retour à la liste

Numérotation des lignes : 

provcc

  1. C PROVCC    SOURCE    PV        22/01/18    21:15:08     11267          
  2.       SUBROUTINE PROVCC(MCHPO1,MCHPO2,MLMOT1,MLMOT2,MLMOT3,MCHPO3)
  3. C-----------------------------------------------------------------------
  4. C                 PRODUIT VECTORIEL 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     MCHPO1   CHPOINT
  11. C     MLMOT1  LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO1
  12. C     Si 3D :
  13. C        MCHPO2   CHPOINT
  14. C        MLMOT2  LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO2
  15. C     MLMOT3  LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT RESULTAT
  16. C  SORTIE
  17. C     MCHPO3    POINTEUR SUR LE CHPOINT RESULTAT
  18. C-----------------------------------------------------------------------
  19.  
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8(A-H,O-Z)
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC SMCHPOI
  26. -INC SMLMOTS
  27. -INC SMELEME
  28. -INC SMCOORD
  29. -INC TMTRAV
  30.  
  31.       CHARACTER*4 NOMIL
  32.       integer*4   iOMIL
  33.       equivalence (nomil,iomil)
  34.       DATA NOMIL/'NOHA'/
  35.  
  36.       LOGICAL LDOUB
  37.  
  38.       CHARACTER*(LOCOMP) NOIN
  39.  
  40.       SEGMENT ITRAV
  41.         REAL*8     IVAA(NINC,NPOI),IVAB(NINC,NPOI)
  42.         INTEGER    IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI)
  43.         CHARACTER*(LOCOMP) INCA(NINC),INCB(NINC)
  44.       ENDSEGMENT
  45. *
  46. * On vérifie qu'il n'y a pas de doublons dans les LISTMOTS
  47. * donnés en entrée
  48. *
  49.       LDOUB=.FALSE.
  50.       CALL CUNIQ2(MLMOT1,MLMOT4)
  51.       CALL CUNIQ2(MLMOT3,MLMOT6)
  52.       IF (IDIM.EQ.3) CALL CUNIQ2(MLMOT2,MLMOT5)
  53.       SEGACT,MLMOT1,MLMOT3,MLMOT4,MLMOT6
  54.       IF (IDIM.EQ.3) SEGACT,MLMOT2,MLMOT5
  55.       NINC1=MLMOT1.MOTS(/2)
  56.       NINC3=MLMOT3.MOTS(/2)
  57.       NINC4=MLMOT4.MOTS(/2)
  58.       NINC6=MLMOT6.MOTS(/2)
  59.       IF (IDIM.EQ.3) THEN
  60.          NINC2=MLMOT2.MOTS(/2)
  61.          NINC5=MLMOT5.MOTS(/2)
  62.       ELSE
  63.          NINC2=IDIM
  64.          NINC5=IDIM
  65.       ENDIF
  66.       LDOUB=LDOUB.OR.(NINC1.NE.NINC4)
  67.       LDOUB=LDOUB.OR.(NINC2.NE.NINC5)
  68.       LDOUB=LDOUB.OR.(NINC3.NE.NINC6)
  69.       SEGSUP,MLMOT4,MLMOT6
  70.       IF (IDIM.EQ.3) SEGSUP,MLMOT5
  71.       IF (LDOUB) THEN
  72. * 1019 2
  73. * Une donnée de type %m1:8 contient des doublons
  74.          MOTERR(1:8)='LISTMOTS'
  75.          CALL ERREUR(1019)
  76.          RETURN
  77.       ENDIF
  78.       IF (NINC1.NE.IDIM.OR.NINC2.NE.IDIM.OR.NINC3.NE.IDIM) THEN
  79. * 1018 2
  80. * On attend un objet de type %m1:8 de dimension %i1
  81.          MOTERR(1:8)='LISTMOTS'
  82.          INTERR(1)=IDIM
  83.          CALL ERREUR(1018)
  84.          RETURN
  85.       ENDIF
  86.       IF (IDIM.EQ.3) GOTO 1000
  87. *
  88. * Cas simple (2D)
  89. *
  90.       SEGINI,MCHPO3=MCHPO1
  91.       NSOUPO=0
  92.       SEGACT MCHPO1
  93.       NSOUP1=MCHPO1.IPCHP(/1)
  94.       DO 30 ISOUP1=1,NSOUP1
  95.          MSOUP1=MCHPO1.IPCHP(ISOUP1)
  96.          SEGACT MSOUP1
  97.          NC1=MSOUP1.NOHARM(/1)
  98.          NX=0
  99.          NY=0
  100. *         WRITE(IOIMP,*) 'MOTS1=',MLMOT1.MOTS(1)
  101. *         WRITE(IOIMP,*) 'MOTS2=',MLMOT1.MOTS(2)
  102.          DO IC1=1,NC1
  103. *            WRITE(IOIMP,*) 'NOCOMP1=',MSOUP1.NOCOMP(IC1)
  104.             IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(1)) NX=IC1
  105.             IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(2)) NY=IC1
  106.          ENDDO
  107.          NC=0
  108.          IF (NX.NE.0) NC=NC+1
  109.          IF (NY.NE.0) NC=NC+1
  110. *         WRITE(IOIMP,*) 'NX=',NX
  111. *         WRITE(IOIMP,*) 'NY=',NY
  112.          IF (NC.EQ.0) GOTO 29
  113.          SEGINI MSOUP3
  114.          MPOVA1=MSOUP1.IPOVAL
  115.          SEGACT MPOVA1
  116.          N=MPOVA1.VPOCHA(/1)
  117.          SEGINI MPOVA3
  118.          IC=0
  119.          IF (NY.NE.0) THEN
  120.             IC=IC+1
  121. *            WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(1)
  122.             MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(1)
  123.             MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NY)
  124.             DO I=1,N
  125.                MPOVA3.VPOCHA(I,IC)=-1*MPOVA1.VPOCHA(I,NY)
  126.             ENDDO
  127.          ENDIF
  128.          IF (NX.NE.0) THEN
  129.             IC=IC+1
  130. *            WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(2)(1:4)
  131.             MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(2)
  132.             MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NX)
  133.             DO I=1,N
  134.                MPOVA3.VPOCHA(I,IC)=MPOVA1.VPOCHA(I,NX)
  135.             ENDDO
  136.          ENDIF
  137.          MSOUP3.IGEOC=MSOUP1.IGEOC
  138.          MSOUP3.IPOVAL=MPOVA3
  139.          NSOUPO=NSOUPO+1
  140.          MCHPO3.IPCHP(NSOUPO)=MSOUP3
  141.  29      CONTINUE
  142.  30   CONTINUE
  143.       NAT=MCHPO3.JATTRI(/1)
  144.       SEGADJ MCHPO3
  145.       RETURN
  146. *
  147. * Cas dimension 3 repris de la subroutine PROSCAL
  148. *
  149.  1000 CONTINUE
  150.       NPOI=nbpts
  151.       MLMOTS=MLMOT1
  152.       SEGACT MLMOTS
  153.       NINC= MOTS(/2)
  154.       SEGINI ITRAV
  155.       DO 1 I = 1, NINC
  156.          INCA(I)=MOTS(I)
  157.   1   CONTINUE
  158.       MLMOTS=MLMOT2
  159.       SEGACT MLMOTS
  160.       IF(MOTS(/2).NE.NINC) THEN
  161.          SEGSUP ITRAV
  162.          MOTERR(1:4)='PVEC'
  163.          MOTERR(5:12)='LISTMOTS'
  164.          CALL ERREUR(125)
  165.          RETURN
  166.       ENDIF
  167.       DO 21 I = 1, NINC
  168.          INCB(I)=MOTS(I)
  169.  21   CONTINUE
  170. C
  171. C *********  IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB
  172. C *********  CREATION D'ABORD DE IVAA PUIS DE IVAB
  173. C
  174.       MCHPOI=MCHPO1
  175.       SEGACT MCHPOI
  176.       NSOUPO = IPCHP(/1)
  177.       DO 2 M = 1,NSOUPO
  178.          MSOUPO = IPCHP(M)
  179.          SEGACT MSOUPO
  180.          NC=NOCOMP(/2)
  181.          DO 10 I = 1,NINC
  182.             IPOS(I)=0
  183.  10      CONTINUE
  184.          DO 4 K = 1, NINC
  185.             DO 3 J = 1, NC
  186.                NOIN= NOCOMP (J)
  187.                IF(INCA(K). EQ . NOIN) THEN
  188.                   IPOS(K)=J
  189.                   GO TO 4
  190.                ENDIF
  191.  3          CONTINUE
  192.  4       CONTINUE
  193.       DO 5 I = 1,NINC
  194.          IF(IPOS(I). NE . 0) GO TO 6
  195.    5  CONTINUE
  196.       GO TO 8
  197.    6  CONTINUE
  198.       MELEME=IGEOC
  199.       SEGACT MELEME
  200.       NBELEM=NUM(/2)
  201.       MPOVAL=IPOVAL
  202.       SEGACT MPOVAL
  203.       DO 9 LI = 1,NINC
  204.          KL = IPOS(LI)
  205.          IF(KL.EQ.0) GO TO 9
  206.          DO 7 I = 1,NBELEM
  207.             I1 = NUM(1,I)
  208.             IVAA(LI,I1)=VPOCHA(I,KL)
  209.             ICPRA(I1)=1
  210.  7       CONTINUE
  211.     9 CONTINUE
  212.     8 CONTINUE
  213.     2 CONTINUE
  214. C
  215. C     TRAITEMENT DU 2-EME CHPOINT
  216. C
  217.       IA=0
  218.       MCHPOI=MCHPO2
  219.       SEGACT MCHPOI
  220.       NSOUPO = IPCHP(/1)
  221.       DO 12 M = 1,NSOUPO
  222.          MSOUPO = IPCHP(M)
  223.          SEGACT MSOUPO
  224.          NC=NOCOMP(/2)
  225.          DO 11 I = 1,NINC
  226.             IPOS(I)=0
  227.  11      CONTINUE
  228.          DO 14  K= 1,NINC
  229.             DO 13  J = 1, NC
  230.                NOIN= NOCOMP (J)
  231.                IF(INCB(K). EQ . NOIN) THEN
  232.                   IPOS(K)=J
  233.                   GO TO 14
  234.                ENDIF
  235.  13         CONTINUE
  236.  14      CONTINUE
  237.          DO 15 I = 1,NINC
  238.             IF(IPOS(I). NE . 0) GO TO 16
  239.  15      CONTINUE
  240.          GO TO 18
  241.  16      CONTINUE
  242.          MELEME=IGEOC
  243.          SEGACT MELEME
  244.          NBELEM=NUM(/2)
  245.          MPOVAL=IPOVAL
  246.          SEGACT MPOVAL
  247.          DO 19 LI = 1,NINC
  248.             KL = IPOS(LI)
  249.             IF(KL.EQ.0) GO TO 19
  250.             DO 17 I = 1,NBELEM
  251.                I1 = NUM(1,I)
  252.                IVAB(LI,I1)=VPOCHA(I,KL)
  253.                IF(ICPRA(I1).NE.0) THEN
  254.                   IA=IA+1
  255.                   ICPRB(I1)=IA
  256.                ENDIF
  257.  17         CONTINUE
  258.  19      CONTINUE
  259.  18      CONTINUE
  260.  12   CONTINUE
  261.       IF(IA.EQ.0) THEN
  262. C
  263. C     CHPOINT VIDE
  264. C
  265.          SEGSUP ITRAV
  266.          NSOUPO=0
  267.          NAT=1
  268.          SEGINI MCHPOI
  269.          IFOPOI=IFOUR
  270.          MCHPO3=MCHPOI
  271.          RETURN
  272.       ENDIF
  273. C
  274. C     ON EFFECTUE LE CALCUL
  275. C
  276.       NNIN=3
  277.       NNNOE=IA
  278.       SEGINI MTRAV
  279.       SEGACT MLMOT3
  280.       DO I=1,3
  281.          INCO(I)=MLMOT3.MOTS(I)
  282.       ENDDO
  283. *
  284. *  MODIF  MILL LE 18 / 7 / 90
  285. *  REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
  286. *
  287.       IF(IFOPOI.EQ.1) THEN
  288.          NHMIL=iomil
  289.          DO I=1,3
  290.             NHAR(1)=NHMIL
  291.          ENDDO
  292.       ENDIF
  293. *
  294.       MCHPOI=MCHPO1
  295.       SEGACT MCHPOI
  296.       NSOUPO=IPCHP(/1)
  297.       DO 22 M=1,NSOUPO
  298.          MSOUPO=IPCHP(M)
  299.          SEGACT MSOUPO
  300.          MELEME=IGEOC
  301.          SEGACT MELEME
  302.          DO 27 J=1,NUM(/2)
  303.             I1=NUM(1,J)
  304.             IB=ICPRB(I1)
  305.             IF(IB.EQ.0) GO TO 27
  306.             IF(IGEO(IB).NE.0) GO TO 27
  307.             IGEO(IB)=I1
  308.             DO 28 LI=1,NINC
  309.                IBIN(LI,IB)=1
  310.  28         CONTINUE
  311.             BB(1,IB)=BB(1,IB)+IVAA(2,I1)*IVAB(3,I1)
  312.      $           -IVAA(3,I1)*IVAB(2,I1)
  313.             BB(2,IB)=BB(2,IB)+IVAA(3,I1)*IVAB(1,I1)
  314.      $           -IVAA(1,I1)*IVAB(3,I1)
  315.             BB(3,IB)=BB(3,IB)+IVAA(1,I1)*IVAB(2,I1)
  316.      $           -IVAA(2,I1)*IVAB(1,I1)
  317.  27      CONTINUE
  318.  22   CONTINUE
  319.       SEGSUP ITRAV
  320.       CALL CRECHP(MTRAV,MCHPO3)
  321.       SEGSUP MTRAV
  322.       RETURN
  323.       END
  324.  
  325.  
  326.  

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