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

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