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

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