Télécharger la plaquette Cast3M


fr en

Télécharger xlapl.eso

Retour à la liste

Numérotation des lignes : 

xlapl

  1. C XLAPL     SOURCE    CB215821  26/08/24    21:18:56     12622          
  2.       SUBROUTINE XLAPL(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,
  3.      & COEF,COG,COES,KITT,KJTT,IK1,
  4.      & LE,NBEL,K0,XCOOR,AIMPL,IKOMP,
  5.      & AF1,AF2,AF3,
  6.      & AS1,AS2,AS3,
  7.      & NINC,IHV,IARG,S2)
  8. C
  9.       IMPLICIT INTEGER(I-N)
  10.       IMPLICIT REAL*8 (A-H,O-Z)
  11. C************************************************************************
  12. C
  13. C     CALCUL MATRICE ELEMENTAIRE DU LAPLACIEN
  14. C
  15. C
  16. C************************************************************************
  17.  
  18. C     DIMENSION FN(NP,NPG),HR(KES,NP,NPG),PGSQ(NPG),RPG(NPG)
  19.       DIMENSION LE(NP,NBEL)
  20.       DIMENSION XYZ(IDIM,NP),FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG)
  21.       DIMENSION HR(IDIM,NP,NPG),PGSQ(NPG),RPG(NPG)
  22.       DIMENSION AF1(NBEL,NP,NP),AF2(NBEL,NP,NP),AF3(NBEL,NP,NP)
  23.       DIMENSION AS1(NBEL,NP,NP),AS2(NBEL,NP,NP),AS3(NBEL,NP,NP)
  24.       DIMENSION CL(9),COEF(1),COES(IDIM,IDIM,*)
  25.       DIMENSION AF(4,4,2,2),XCOOR(*)
  26. C
  27.       DIMENSION COE(3,3),S2(IDIM,1),COG(2,1)
  28.  
  29. C     write(6,*)' XLAPL  KITT,KJTT,IK1 =',KITT,KJTT,IK1
  30.       NK=K0
  31.       DO 108 KE=1,NBEL
  32.       NK=NK+1
  33.       DO 1764 I=1,NP
  34.       J=LE(I,KE)
  35.       DO 109 N=1,IDIM
  36.       XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
  37.  109  CONTINUE
  38.  1764 CONTINUE
  39.  
  40.       CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  41.      *IDIM,NP,NPG,IAXI,AIRE)
  42. C
  43.       IAX=0
  44. C     WRITE(6,*)
  45. C     WRITE(6,*)' KITT ',KITT,' KJTT ',KJTT
  46. C     if(iax.eq.0)go to 108
  47.       IF(IHV.EQ.1)IAX=IAXI
  48.       IF(KITT.EQ.4)GO TO 70
  49.       IF(KITT.EQ.3)GO TO 80
  50.       IF(KITT.EQ.1)GO TO 80
  51.       IF(KJTT.EQ.4)GO TO 5
  52.       IC=1+(1-IK1)*(NK-1)
  53. C     WRITE(6,*)' IC ',IC ,COEF(IC)
  54.       DO 1765 I=1,NP
  55.       DO 1 J=1,NP
  56.       U=0.D0
  57.       DO 2 L=1,NPG
  58.       V=0.D0
  59.       DO 3 N=1,IDIM
  60.       V=V+HR(N,I,L)*HR(N,J,L)
  61.  3    CONTINUE
  62.       U=U+V*PGSQ(L)
  63.  2    CONTINUE
  64.       U=U*COEF(IC)
  65.       AF1(KE,J,I)=AF1(KE,J,I)+U*AIMPL
  66.       AS1(KE,J,I)=AS1(KE,J,I)+U*(AIMPL-1.D0)
  67.  1    CONTINUE
  68.  1765 CONTINUE
  69.  
  70.       IF(NINC.GE.2)THEN
  71.       DO 1766 I=1,NP
  72.       DO 1762 J=1,NP
  73.       AF2(KE,I,J)=AF1(KE,I,J)
  74.       AS2(KE,I,J)=AS1(KE,I,J)
  75.  1762 CONTINUE
  76.  1766 CONTINUE
  77.       ENDIF
  78.       IF(NINC.GE.3)THEN
  79.       DO 1767 I=1,NP
  80.       DO 1763 J=1,NP
  81.       AF3(KE,I,J)=AF1(KE,I,J)
  82.       AS3(KE,I,J)=AS1(KE,I,J)
  83.  1763 CONTINUE
  84.  1767 CONTINUE
  85.       ENDIF
  86.  
  87.       IF(IHV.EQ.1)THEN
  88.       IF(IAXI.EQ.1)THEN
  89.       DO 1768 I=1,NP
  90.       DO 41 J=1,NP
  91.       U=0.D0
  92.       DO 42 L=1,NPG
  93.       U=U+FN(I,L)*FN(J,L)/RPG(L)/RPG(L)*PGSQ(L)
  94.  42   CONTINUE
  95.       U=U*COEF(IC)
  96.       AF2(KE,J,I)=AF2(KE,J,I)+U*AIMPL
  97.       AS2(KE,J,I)=AS2(KE,J,I)+U*(AIMPL-1.D0)
  98.  41   CONTINUE
  99.  1768 CONTINUE
  100.       ELSEIF(IAXI.EQ.2)THEN
  101.       DO 1769 I=1,NP
  102.       DO 43 J=1,NP
  103.       U=0.D0
  104.       DO 44 L=1,NPG
  105.       U=U+FN(I,L)*FN(J,L)/RPG(L)/RPG(L)*PGSQ(L)
  106.  44   CONTINUE
  107.       U=U*COEF(IC)
  108.       AF1(KE,J,I)=AF1(KE,J,I)+U*AIMPL
  109.       AS1(KE,J,I)=AS1(KE,J,I)+U*(AIMPL-1.D0)
  110.  43   CONTINUE
  111.  1769 CONTINUE
  112.       ENDIF
  113.       ENDIF
  114.       GO TO 108
  115.  
  116.  5    CONTINUE
  117.       DO 51 L=1,NPG
  118.       C=0.D0
  119.       DO 52 I=1,NP
  120.       IU=LE(I,KE)
  121.       C=C+COEF(IU)*FN(I,L)
  122.  52   CONTINUE
  123.       CL(L)=C
  124.  51   CONTINUE
  125. C
  126. C     write(6,*)' BCL 15 '
  127.       DO 1770 I=1,NP
  128.       DO 15 J=I,NP
  129.       U=0.D0
  130.       DO 12 L=1,NPG
  131.       V=0.D0
  132.       DO 13 N=1,IDIM
  133.       V=V+HR(N,I,L)*HR(N,J,L)
  134.  13   CONTINUE
  135.       U=U+V*PGSQ(L)*CL(L)
  136.  12   CONTINUE
  137.       DO 14 K=1,NINC
  138.       AF(J,I,K,K)=AF(J,I,K,K)+U
  139.       IF(I.NE.J)AF(I,J,K,K)=AF(I,J,K,K)+U
  140.  14   CONTINUE
  141.       IF(IAX.EQ.0)GO TO 15
  142.       U=0.D0
  143.       DO 410 L=1,NPG
  144.       U=U+FN(I,L)*FN(J,L)/RPG(L)/RPG(L)*PGSQ(L)*CL(L)
  145.  410  CONTINUE
  146.       KU=3-IAX
  147.       AF(J,I,KU,KU)=AF(J,I,KU,KU)+U
  148.       IF(I.NE.J)AF(I,J,KU,KU)=AF(I,J,KU,KU)+U
  149.  15   CONTINUE
  150.  1770 CONTINUE
  151.       GO TO 108
  152. C
  153. C
  154.  70   CONTINUE
  155.       IF(NINC.NE.1)CALL ARRET(0)
  156.       IF(KJTT.EQ.4)CALL ARRET(0)
  157.       IC=1+(1-IK1)*(NK-1)
  158.       DO 1771 I=1,NP
  159.       DO 71 J=1,NP
  160.       U=0.D0
  161.       DO 72 L=1,NPG
  162.       UL=0.D0
  163.       DO 73 M=1,IDIM
  164.       UN=0.D0
  165.       DO 74 N=1,IDIM
  166.       UN=UN+COES(N,M,IC)*HR(N,J,L)
  167.  74   CONTINUE
  168.       UL=UL+UN*HR(M,I,L)
  169.  73   CONTINUE
  170.       U=U+UL*PGSQ(L)
  171.  72   CONTINUE
  172.       AF(J,I,1,1)=AF(J,I,1,1)+U
  173.  71   CONTINUE
  174.  1771 CONTINUE
  175.       GO TO 108
  176. C
  177. C
  178.    80 CONTINUE
  179.       IF(KJTT.EQ.4)CALL ARRET(0)
  180.       IF(IARG.EQ.0)CALL ARRET(0)
  181.       IC=1+(1-IK1)*(NK-1)
  182.       ALT=COG(1,IC)-COG(2,IC)
  183.       AT=COG(2,IC)
  184. C     WRITE(6,*)' ALT ',ALT,' AT ',AT
  185.       IF(IDIM.EQ.2) THEN
  186.       CO=SQRT(S2(1,IC)*S2(1,IC)+S2(2,IC)*S2(2,IC))
  187.       ENDIF
  188.       IF(IDIM.EQ.3) THEN
  189.       CO=SQRT(S2(1,IC)*S2(1,IC)+S2(2,IC)*S2(2,IC)+S2(3,IC)*S2(3,IC))
  190.       ENDIF
  191. C     WRITE(6,*)' CO ',CO
  192. C     WRITE(6,*)' S2 ',S2(1,IC),S2(2,IC)
  193.       IF(IDIM.EQ.2) THEN
  194.       COE(1,1)=ALT*S2(1,IC)*S2(1,IC)/CO+AT*CO
  195.       COE(2,2)=ALT*S2(2,IC)*S2(2,IC)/CO+AT*CO
  196.       COE(1,2)=ALT*S2(1,IC)*S2(2,IC)/CO
  197.       COE(2,1)=COE(1,2)
  198.       ENDIF
  199.       IF(IDIM.EQ.3) THEN
  200.       COE(1,1)=ALT*S2(1,IC)*S2(1,IC)/CO+AT*CO
  201.       COE(2,2)=ALT*S2(2,IC)*S2(2,IC)/CO+AT*CO
  202.       COE(3,3)=ALT*S2(3,IC)*S2(3,IC)/CO+AT*CO
  203.       COE(1,2)=ALT*S2(1,IC)*S2(2,IC)/CO
  204.       COE(1,3)=ALT*S2(1,IC)*S2(3,IC)/CO
  205.       COE(2,3)=ALT*S2(2,IC)*S2(3,IC)/CO
  206.       COE(2,1)=COE(1,2)
  207.       COE(3,1)=COE(1,3)
  208.       COE(3,2)=COE(2,3)
  209.       ENDIF
  210. C     WRITE(6,*)' COE ',COE(1,1),COE(1,2),COE(1,3)
  211. C     WRITE(6,*)'     ',COE(2,1),COE(2,2),COE(2,3)
  212. C     WRITE(6,*)'     ',COE(3,1),COE(3,2),COE(3,3)
  213. C
  214.       DO 1772 I=1,NP
  215.       DO 81 J=1,NP
  216.       U=0.D0
  217.       DO 82 L=1,NPG
  218.       UL=0.D0
  219.       DO 83 M=1,IDIM
  220.       UN=0.D0
  221.       DO 84 N=1,IDIM
  222.       UN=UN+COE(N,M)*HR(N,J,L)
  223.  84   CONTINUE
  224.       UL=UL+UN*HR(M,I,L)
  225.  83   CONTINUE
  226.       U=U+UL*PGSQ(L)
  227.  82   CONTINUE
  228.       AF(J,I,1,1)=AF(J,I,1,1)+U
  229.  81   CONTINUE
  230.  1772 CONTINUE
  231.  
  232.  108  CONTINUE
  233.  
  234. C     write(6,*)' FIN XLAPL'
  235.  
  236.       RETURN
  237.  1002 FORMAT(10(1X,1PE11.4))
  238.  1001 FORMAT(20(1X,I5))
  239.       END
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  

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