Télécharger la plaquette Cast3M


fr en

Télécharger provc3.eso

Retour à la liste

Numérotation des lignes : 

provc3

  1. C PROVC3    SOURCE    CB215821  20/11/04    21:20:41     10766          
  2. C 
  3.       SUBROUTINE PROVC3(IPCHE1,IPCHE2,IPLMO1,IPLMO2,IPLMO3,IPCHE3)
  4. *********************************************************************
  5. *                 PRODUIT VECTORIEL DE 2 CHAMELEMS (en 3D)
  6. *********************************************************************
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8(A-H,O-Z)
  9. C--------------------------------------------------------------------
  10. C  ENTREE
  11. C     IPCHE1   CHAMELEM
  12. C     IPCHE2   CHAMELEM
  13. C     MLMOT1  LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER  CHAMP
  14. C     MLMOT2  LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHAMP
  15. C     MLMOT3  LISTMOTS DE COMPOSANTES ASSOCIEES AU 3-EME CHAMP
  16. C  SORTIE
  17. C     IPCHE3    POINTEUR SUR LE MCHAML RESULTAT
  18. c
  19. c BP,2020 : inspire de SCACHA.eso, voir aussi PROVC2.eso
  20. c
  21. C--------------------------------------------------------------------
  22.  
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCHAMP
  27. -INC SMCHAML
  28. -INC SMELEME
  29. -INC SMLMOTS
  30. C
  31.       CHARACTER*(LOCOMP) NOIN
  32. c     tableau des indices pour le produit vectoriel
  33.       INTEGER     KCOMP1(3),KCOMP2(3)
  34.       DATA        KCOMP1/2,3,1/
  35.       DATA        KCOMP2/3,1,2/
  36. C
  37.       IPCHE3=0
  38. C
  39. C=========================================================
  40. C     RECUP DES LISTMOTS + VERIF DES DIMENSIONS
  41. C=========================================================
  42.  
  43. *     LISTE 1
  44.       MLMOT1=IPLMO1
  45.       SEGACT MLMOT1
  46.       NINC = MLMOT1.MOTS(/2)
  47. *     LISTE 2
  48.       MLMOT2=IPLMO2
  49.       SEGACT MLMOT2
  50.       IF(MLMOT2.MOTS(/2).NE.NINC) THEN
  51.         SEGDES MLMOT1,MLMOT2
  52.         MOTERR(1:4)='PVEC'
  53.         MOTERR(5:12)='LISTMOTS'
  54.         CALL ERREUR(125)
  55.         RETURN
  56.       ENDIF
  57.  
  58. *     liste 3
  59.       MLMOTS=IPLMO3
  60.       SEGACT MLMOTS
  61.       IF(MOTS(/2).NE.NINC) THEN
  62.         SEGDES MLMOTS
  63.         MOTERR(1:4)='PVEC'
  64.         MOTERR(5:12)='LISTMOTS'
  65.         CALL ERREUR(125)
  66.         RETURN
  67.       ENDIF
  68.  
  69.  
  70. C=========================================================
  71. C     VERIFICATION DU LIEU SUPPORT DES MCHAML
  72. C       presence des memes sous zones
  73. C       presence des composantes declarées
  74. C       identité des points supports
  75. C=========================================================
  76. C
  77.       MCHEL1=IPCHE1
  78.       MCHEL2=IPCHE2
  79.       SEGACT MCHEL1,MCHEL2
  80.       N1=MCHEL1.IMACHE(/1)
  81.       NP1=MCHEL2.IMACHE(/1)
  82. C  verification du nombre de sous zones geometriques
  83.       if(N1.ne.NP1)  then
  84.         CALL ERREUR(329)
  85.         segdes MCHEL1,mchel2
  86.         return
  87.       endif
  88.  
  89.       if(mchel1.ifoche.ne.mchel2.ifoche) then
  90.         call erreur(21)
  91.         segdes MCHEL1,mchel2
  92.         return
  93.       endif
  94.  
  95.       L1=11
  96.       N3=6
  97.       SEGINI MCHEL3,MCHEL4
  98. C
  99. C   on fabrique deux CHAMPS temporaires ordonnés
  100. C
  101.       ipb1 = 0
  102. c---- boucle sur les sous-zones -----------------
  103.       DO 10  ISOUS = 1,N1
  104.  
  105.         in1 = 0
  106.         in2 = 0
  107.  
  108.         IPT1 = MCHEL1.IMACHE(ISOUS)
  109.         MCHAM1 = MCHEL1.ICHAML(ISOUS)
  110.         SEGACT MCHAM1
  111.         N2=NINC
  112.         SEGINI MCHAM3,MCHAM4
  113.  
  114.         do 16 j=1,ninc
  115.         do 17 k=1,MCHAM1.nomche(/2)
  116.           noin = MCHAM1.nomche(k)
  117.           if(noin.eq.MLMOT1.MOTS(j)) then
  118.             in1= in1 + 1
  119.             MCHEL3.IMACHE(isous)=IPT1
  120.             MCHEL3.ICHAML(isous)=MCHAM3
  121.             inf1 = mchel1.infche(isous,3)
  122.             inf2 = mchel1.infche(isous,4)
  123.             melva1= MCHAM1.IELVAL(k)
  124.             segini ,melval=melva1
  125.             MCHAM3.IELVAL(in1)=melval
  126.             MCHAM3.NOMCHE(in1)=noin
  127.               segdes melva1
  128. *bp,2020      segdes melval
  129.             goto 16
  130.           endif
  131. 17      continue
  132. 16      continue
  133. C
  134.         segdes mcham1
  135. C
  136.         DO 12  ii = 1,N1
  137.           IPT2 = MCHEL2.IMACHE(II)
  138.           if(ipt2.eq.ipt1) then
  139.             MCHAM2 = MCHEL2.ICHAML(II)
  140.             SEGACT MCHAM2
  141.             do 18 j=1,ninc
  142.             do 19 k=1,MCHAM2.nomche(/2)
  143.             noin = MCHAM2.nomche(k)
  144.             if(noin.eq.MLMOT2.MOTS(j)) then
  145.               in2= in2 + 1
  146.               if(mchel2.infche(II,3).ne.inf1.or.
  147.      &           mchel2.infche(II,4).ne.inf2) then
  148.                 ipb1 = 1
  149.               endif
  150.               MCHEL4.IMACHE(isous) = IPT2
  151.               MCHEL4.ICHAML(isous) = MCHAM4
  152.               melva1 = MCHAM2.IELVAL(k)
  153.               segini , melval=melva1
  154.               MCHAM4.IELVAL(in2) = melval
  155.               MCHAM4.NOMCHE(in2)=noin
  156.               segdes melva1
  157. *bp,2020      segdes melval
  158.               goto 18
  159.             endif
  160. 19          continue
  161. 18          continue
  162.             segdes mcham2
  163.           endif
  164. 12      CONTINUE
  165.  
  166. c       erreur 175 : supports incompatibles
  167.         if(ipb1.eq.1) then
  168.           moterr(1:8) = MCHEL1.TITCHE(1:8)
  169.           moterr(9:16)= MCHEL2.TITCHE(1:8)
  170.           segdes mchel1,mchel2
  171.           segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4
  172.           call erreur(175)
  173.           RETURN
  174.         endif
  175.  
  176. C       erreur : Probleme  entre composantes des champs et les LISTMOTS
  177.         if(in1.ne.ninc.or.in2.ne.ninc) then
  178.           segdes mchel1,mchel2
  179.           segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4
  180.           call erreur(911)
  181.           RETURN
  182.         endif
  183.  
  184. 10    CONTINUE
  185. c---- fin de boucle sur les sous-zones -----------------
  186. C
  187.       if (mchel1.ne.mchel2) segdes mchel2
  188.  
  189.  
  190. C=========================================================
  191. C     CREATION DU MCHELM
  192. C=========================================================
  193. C
  194.       L1=4
  195.       N3=6
  196. C
  197.       SEGINI MCHELM
  198.       TITCHE='PVEC'
  199.  
  200.       IFOCHE=MCHEL1.IFOCHE
  201.       IPCHE3=MCHELM
  202. C____________________________________________________________________
  203. C
  204. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  205. C____________________________________________________________________
  206. C
  207.       DO 500 ISOUS=1,N1
  208. *
  209. *     INITIALISATION
  210. *
  211.  
  212.       MELEME = MCHEL1.IMACHE(ISOUS)
  213.       IMACHE(ISOUS)= MELEME
  214.       CONCHE(ISOUS)= MCHEL1.CONCHE(ISOUS)
  215. C
  216. C
  217.       INFCHE(ISOUS,1)=0
  218.       INFCHE(ISOUS,2)=0
  219.       INFCHE(ISOUS,3)=MCHEL1.INFCHE(ISOUS,3)
  220.       INFCHE(ISOUS,4)=MCHEL1.INFCHE(ISOUS,4)
  221.       INFCHE(ISOUS,5)=0
  222.       INFCHE(ISOUS,6)=MCHEL1.INFCHE(ISOUS,6)
  223. C
  224. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  225. C     bp (septembre 2009): modif pour permettre d'avoir des zones de champs
  226. C     cst et d'autres variables => differentes tailles de supports
  227. C     bp,2020: ajout du cas : MELVA1 cst * MELVA2 variable
  228. C
  229.       MCHAM3=MCHEL3.ICHAML(ISOUS)
  230.       MCHAM4=MCHEL4.ICHAML(ISOUS)
  231.       N1PTEL = 0
  232.       N1EL   = 0
  233.       DO ICOMP=1,NINC
  234.         MELVA1 = MCHAM3.IELVAL(ICOMP)
  235.         MELVA2 = MCHAM4.IELVAL(ICOMP)
  236.         SEGACT MELVA1,MELVA2
  237.         N1PTEL = max(N1PTEL,MELVA1.VELCHE(/1))
  238.         N1EL   = max(N1EL  ,MELVA1.VELCHE(/2))
  239.         N1PTEL = max(N1PTEL,MELVA2.VELCHE(/1))
  240.         N1EL   = max(N1EL  ,MELVA2.VELCHE(/2))
  241. cbp,2020         SEGDES MELVA1,MELVA2
  242.       ENDDO
  243. C
  244. C     CREATION DU MCHAML RESULTAT DE LA SOUS ZONE
  245. C
  246.       N2=NINC
  247.       SEGINI MCHAML
  248.  
  249.       ICHAML(ISOUS)=MCHAML
  250.  
  251. c
  252. c----- BOUCLE SUR LES COMPOSANTES RESULTATS ---------------      
  253. c
  254.        DO 110  ICOMP=1,NINC
  255.  
  256. c        Creation du MELVAL resultat
  257.          NOMCHE(ICOMP)=MLMOTS.MOTS(ICOMP)
  258.          TYPCHE(ICOMP)='REAL*8'
  259.          N2PTEL=0
  260.          N2EL=0
  261.          SEGINI MELVAL
  262.          IELVAL(ICOMP)=MELVAL
  263.  
  264. c    +++ les composantes +++
  265.          ICOMP1=KCOMP1(ICOMP)
  266.          ICOMP2=KCOMP2(ICOMP)
  267.  
  268. c    +++ on met dans le resultat le produit des composantes +++
  269.          MELVA1= MCHAM3.IELVAL(ICOMP1)
  270.          MELVA2= MCHAM4.IELVAL(ICOMP2)
  271.          segact melva1,melva2
  272.          IB1MAX = MELVA1.VELCHE(/1)
  273.          IE1MAX = MELVA1.VELCHE(/2)
  274.          IB2MAX = MELVA2.VELCHE(/1)
  275.          IE2MAX = MELVA2.VELCHE(/2)
  276.          DO  IE= 1,N1EL
  277.          DO  IB= 1,N1PTEL
  278.            IB1 = min(IB,IB1MAX)
  279.            IB2 = min(IB,IB2MAX)
  280.            IE1 = min(IE,IE1MAX)
  281.            IE2 = min(IE,IE2MAX)
  282.            VELCHE(IB,IE)=MELVA1.VELCHE(IB1,IE1)*MELVA2.VELCHE(IB2,IE2)
  283.          ENDDO
  284.          ENDDO
  285. cbp,2020       segdes melva1,melva2
  286.  
  287. c    +++ on soustrait le produit des composantes inversees +++
  288.          MELVA1= MCHAM3.IELVAL(ICOMP2)
  289.          MELVA2= MCHAM4.IELVAL(ICOMP1)
  290.          segact melva1,melva2
  291.          IB1MAX = MELVA1.VELCHE(/1)
  292.          IE1MAX = MELVA1.VELCHE(/2)
  293.          IB2MAX = MELVA2.VELCHE(/1)
  294.          IE2MAX = MELVA2.VELCHE(/2)
  295.          DO  IE= 1,N1EL
  296.          DO  IB= 1,N1PTEL
  297.            IB1 = min(IB,IB1MAX)
  298.            IB2 = min(IB,IB2MAX)
  299.            IE1 = min(IE,IE1MAX)
  300.            IE2 = min(IE,IE2MAX)
  301.            VELCHE(IB,IE)=VELCHE(IB,IE) 
  302.      &     - MELVA1.VELCHE(IB1,IE1)*MELVA2.VELCHE(IB2,IE2)
  303.          ENDDO
  304.          ENDDO
  305. cbp,2020         segdes,MELVAL
  306.  
  307. 110    CONTINUE
  308. c----- FIN DE BOUCLE SUR LES COMPOSANTES RESULTATS ---------------      
  309. C
  310. C      segsup MCHAM3,MCHAM4 --> dtcham
  311. cbp,2020      segdes,MCHAML
  312.  
  313. 500   CONTINUE
  314. C____________________________________________________________________
  315. C
  316. C     FIN DE BOUCLE SUR LES ZONES 
  317. C____________________________________________________________________
  318.  
  319.       call dtcham(mchel3)
  320.       call dtcham(mchel4)
  321.       segdes mchel1
  322. cbp,2020      segdes,mchelm
  323.  
  324.       RETURN
  325.       END
  326.  
  327.  
  328.  
  329.  
  330.  

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