Télécharger la plaquette Cast3M


fr en

Télécharger scacha.eso

Retour à la liste

Numérotation des lignes : 

scacha

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

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