Télécharger la plaquette Cast3M


fr en

Télécharger xxsour.eso

Retour à la liste

Numérotation des lignes : 

xxsour

  1. C XXSOUR    SOURCE    CB215821  20/11/25    13:43:37     10792          
  2.       SUBROUTINE XXSOUR(KPOIND,NOMD4,MCHPO1,XPG,MELEME,MELEMD,SPGD,
  3.      & MCHEL4,INEFMD)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6. C***********************************************************************
  7. C
  8. C     SYNTAXE :
  9. C
  10. C                   /             /
  11. C      On calcule   |  W S  do  = | Ma NbSb do
  12. C                   /             /
  13. C       EN 2D
  14. C              elements SEG2  -> Flux
  15. C              elements TRI3  -> Source volumique
  16. C              elements QUA4  -> Source volumique
  17. C       EN 3D
  18. C              elements SEG2  -> Pas de sens !!
  19. C              elements TRI3  -> Flux
  20. C              elements QUA4  -> Flux
  21. C              elements CUB8  -> Source volumique
  22. C              elements PRI6  -> Source volumique
  23. C              elements TET4  -> Source volumique
  24. C
  25. C***********************************************************************
  26.  
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCREEL
  31. -INC CCGEOME
  32. -INC SMCHAML
  33. -INC SMCOORD
  34. -INC SMLENTI
  35. -INC SMELEME
  36.       POINTEUR MELEMD.MELEME,SPGD.MELEME
  37. -INC SMCHPOI
  39. -INC SIZFFB
  40.       POINTEUR IZF1.IZFFM,IZH2.IZHR,IZW.IZFFM,IZWH.IZHR
  41.       SEGMENT SAJT
  42.       REAL*8 AJT(IDIM,IDIM,NPG),RF1(NP,MP,IDIM),SM1(NP,IDIM)
  43.       REAL*8 TN1(NP,IDIM),TN2(NP,IDIM)
  44.       ENDSEGMENT
  45.  
  46. -INC SMLMOTS
  47.       CHARACTER*8 TYPE,NOM0,TYPC,MTERR
  48.       CHARACTER*4 NOMD4
  49.       LOGICAL XPG
  50. C*****************************************************************************
  51. CXXSOUR
  52. C     write(6,*)' Debut XXSOUR'
  53.  
  54. C*****************************************************************************
  55. C OPTIONS
  56. C KFORM = 0 -> SI       1 -> EF       2 -> VF    3 -> EFMC
  57. C IDCEN = 0->rien   1-> CENTREE  2-> SUPGDC  3-> SUPG     4-> TVISQUEU 5-> CNG
  58. C KPOIN = 0->SOMMET 1-> FACE     2-> CENTRE  3-> CENTREP0 4-> CENTREP1 5-> MSOMMET
  59. C E/  MMODEL : Pointeur de la table contenant l'information cherchée
  60. C  /S IPOINT : Pointeur sur la table DOMAINE
  61. C  /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE
  62. C                               INEFMD=4 LINB
  63.  
  64.  
  65.       IF(XPG)THEN
  66.       CALL ARRET(0)
  67.       ENDIF
  68.  
  69. c     IK3=0
  70.       IAXI=0
  71.       IF(IFOMOD.EQ.0)IAXI=2
  72.       DEUPI=1.D0
  73.       IF(IAXI.NE.0)DEUPI=2.D0*XPI
  74.  
  75.       CALL LICHTM(MCHPO1,MPOVA1,TYPC,IGEOM)
  76.       NC=MPOVA1.VPOCHA(/2)
  77.       CALL KRIPAD(SPGD,MLENTI)
  78.  
  79.       SEGACT MELEME
  80.       SEGACT MCHEL4
  81.  
  82.       NKD=0
  83.       DO 101 L=1,MAX(1,LISOUS(/1))
  84.       SEGACT MELEMD
  85.       IPT1=MELEME
  86.       IPT2=MELEMD
  87.       IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
  88.       SEGACT IPT1
  89.       IF(MELEMD.LISOUS(/1).NE.0)THEN
  90.       IPT2=MELEMD.LISOUS(L)
  91.       NKD=0
  92.       ENDIF
  93.       SEGACT IPT2
  94.       MP=IPT2.NUM(/1)
  95.  
  96. C-----------------------------------------------------------------------
  97.       IF(KPOIND.NE.2)THEN
  98.        IF(INEFMD.EQ.3)THEN
  99.        IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PRP0'
  100.        IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PRP1'
  101.        IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'PFP1'
  102.        ELSEIF(INEFMD.EQ.2)THEN
  103.        IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'MCP0'
  104.        IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCP1'
  105.        IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'MCF1'
  106.        ELSEIF(INEFMD.EQ.1)THEN
  107.        IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'P1P1'
  108.        ELSEIF(INEFMD.EQ.4)THEN
  109.        NOM0=NOMS(IPT1.ITYPEL)//'    '
  110.        ENDIF
  111.       ENDIF
  112.  
  113.       IF(KPOIND.EQ.2)THEN
  114.       NOM0 = NOMS(IPT1.ITYPEL)//NOMD4
  115.       ENDIF
  116.  
  117.       IF(KPOIND.EQ.0)THEN
  118.       NOM0 = NOMS(IPT1.ITYPEL)
  119.       NOM0 = NOMS(IPT1.ITYPEL)//NOMD4
  120.       ENDIF
  121. C-----------------------------------------------------------------------
  122. c     write(6,*)' XXSOUR 1er KALPBG NOM0=',NOM0,IPT1
  123.       CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  124.       IF(IZFFM.EQ.0)RETURN
  125.       SEGACT IZFFM*MOD
  126.       IZHR=KZHR(1)
  127.       SEGACT IZHR*MOD
  128.       IZF1 = KTP(1)
  129.       IZH2 = KZHR(2)
  130.       IZW  = IZF1
  131.       IF(KPOIND.EQ.0)IZW=IZFFM
  132.       SEGACT IZW*MOD
  133.       IF(MP.NE.IZW.FN(/1))THEN
  134. c     write(6,*)' Gross problem XXSOUR '
  135. c     write(6,*)' NOM0=',NOM0 ,' NOMD4=',NOMD4
  136. c     write(6,*)' MP=',MP,' KPOIND.=',KPOIND,' IZW.FN(/1)='
  137. c    & ,IZW.FN(/1)
  138.       ENDIF
  139.  
  140.       NES=GR(/1)
  141.       NPG=GR(/3)
  142.       NP = IPT1.NUM(/1)
  143.       NBEL=IPT1.NUM(/2)
  144.  
  145.       SEGINI SAJT
  146.       MCHAM4=MCHEL4.ICHAML(L)
  147.       SEGACT MCHAM4
  148.  
  149.       MELVA4=MCHAM4.IELVAL(1)
  150.       SEGACT MELVA4
  151.       N1PTEL=MELVA4.VELCHE(/1)
  152.       N1EL=MELVA4.VELCHE(/2)
  153. c      write(6,*)' N1PTEL=',N1PTEL,'N1EL=',N1EL
  154.         IF(N1EL.EQ.1)THEN
  155.         IK4=1
  156.         ELSEIF(N1EL.EQ.NBEL)THEN
  157.         IK4=0
  158.         ENDIF
  159. c      write(6,*)' AVANT 108 NC=',NC,' NBEL=',NBEL,MP,NP,NC
  160. c      write(6,*)' AVANT 108 IK4=',IK4,'N1PTEL=',N1PTEL,'N1EL=',N1EL
  161.  
  162. c         write(6,*)' '
  163. c         write(6,*)' XXSOUR ---------------------------------------'
  164. c         nche1=MELVA4.VELCHE(/1)
  165. c         nche2=MELVA4.VELCHE(/2)
  166. c         write(6,*)' MELVA4=',MELVA4
  167. c         write(6,*)' MCHEL4=',MCHEL4,'  nche1=',nche1,'  nche2=',nche2
  168. c         write(6,*)' NC=',NC,' MP=',MP,' NP=',NP,' NPG=',NPG
  169. c         write(6,*)' IDIM=',IDIM,' NBEL=',nbel
  170. c         write(6,*)' XXSOUR ---------------------------------------'
  171. c         write(6,*)' '
  172.  
  173.         DO 108 KE=1,NBEL
  174.  
  175.         NKD=NKD+1
  176. c       NK1=KE + IK1*(1 - KE)
  177. c       NK2=KE + IK2*(1 - KE)
  178. c       NK3=KE + IK3*(1 - KE)
  179.         NK4=KE + IK4*(1 - KE)
  180.  
  181.         DO     I=1,NP
  182.         J=IPT1.NUM(I,KE)
  183.         DO     N=1,IDIM
  184.         XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
  185.         ENDDO
  186.         ENDDO
  187.  
  188.         CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  189.      *  IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  190.  
  191.         CALL INITD(SM1,(MP*IDIM),0.D0)
  192.  
  193. C=======================================================================
  194.  
  195. C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  196. C...... Source
  197.         DO 710 I=1,MP
  198.           U4=0.D0
  199.           C1=1.D0
  200.          DO 717 N=1,NC
  201.           DO 715 LG=1,NPG
  202.           WT=IZW.FN(I,LG)
  203. c         IF(XPG)THEN
  204. c         WT=MELVA3.VELCHE((IDIM+I-1)*NPG+LG,NK3)+IZW.FN(I,LG)
  205. c         ENDIF
  206.           C4=MELVA4.VELCHE((N-1)*NPG+LG,NK4)
  207.  
  208.           U4=U4+WT*PGSQ(LG)*C4*DEUPI*RPG(LG)
  209.  715      CONTINUE
  210.           SM1(I,N)=SM1(I,N)+ U4
  211.  717     CONTINUE
  212.  710    CONTINUE
  213. C...... Source Fin
  214. C=======================================================================
  215.  
  216.  
  217. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  218. C ...... Chargement Second membre
  219.         DO 911 I=1,MP
  220.          I1=LECT(IPT2.NUM(I,KE))
  221.         DO 910 N=1,NC
  222.          MPOVA1.VPOCHA(I1,N)=MPOVA1.VPOCHA(I1,N)+SM1(I,N)
  223.  910    CONTINUE
  224.  911    CONTINUE
  225. C<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  226.  
  227.  108    CONTINUE
  228.  
  229.       SEGDES IPT1,IPT2
  230.       SEGSUP MCHAM4,MELVA4
  231.  
  232.       SEGSUP IZFFM,IZHR,IZF1,IZH2
  233.       SEGSUP SAJT
  234.  
  235.  101  CONTINUE
  236.       SEGDES MPOVA1
  237.       SEGSUP MLENTI
  238.       SEGSUP MCHEL4
  239.  
  240.  
  241. c     write(6,*)' FIN XXSOUR'
  242.       RETURN
  243.  1002 FORMAT(10(1X,1PE11.4))
  244.  1001 FORMAT(10(1X,I7))
  245.       END
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  

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