Esope source files

   1 : C BB403     SOURCE    CHAT      05/01/12    21:35:58     5004           
   2 :       SUBROUTINE BB403(X,Y,Z,PG,FN,GR,FM,GM,ND,NP,MP,NPG)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)
   5 : C***********************************************************************
   6 : C
   7 : C     CALCULE LES FONCTIONS DE FORME D'UN : TET5 (TET4 + Bulle)
   8 : C
   9 : C***********************************************************************
  10 :       REAL*8 X(NPG),Y(NPG),Z(NPG)
  11 :       DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG)
  12 :       DIMENSION FM(MP,NPG),GM(ND,MP,NPG)
  13 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  14 :       CO=6.D0 ** (1.D0/3.D0)
  15 :       ALFA=(4.D0/CO)**4.D0
  16 : C
  17 :       IF(NPG.EQ.1)THEN
  18 :          XXXX=0.25D0*CO
  19 : C
  20 :          X(1)=XXXX
  21 :          Y(1)=XXXX
  22 :          Z(1)=XXXX
  23 :          PG(1)=1.D0
  24 :       ENDIF
  25 :       IF(NPG.EQ.4)THEN
  26 :          AL=.5854101966249684D0*CO
  27 :          BE=.1381966011250105D0*CO
  28 : C
  29 :          X(1)=BE
  30 :          Y(1)=BE
  31 :          Z(1)=BE
  32 :          PG(1)=0.25D0
  33 : C
  34 :          X(2)=AL
  35 :          Y(2)=BE
  36 :          Z(2)=BE
  37 :          PG(2)=0.25D0
  38 : C
  39 :          X(3)=BE
  40 :          Y(3)=AL
  41 :          Z(3)=BE
  42 :          PG(3)=0.25D0
  43 : C
  44 :          X(4)=BE
  45 :          Y(4)=BE
  46 :          Z(4)=AL
  47 :          PG(4)=0.25D0
  48 : C
  49 :       ENDIF
  50 : C
  51 :       UNSCO=1.D0/CO
  52 :       XXXX=-CO
  53 :       DO 1 L=1,NPG
  54 :       BB=(CO-X(L)-Y(L)-Z(L))*X(L)*Y(L)*Z(L)*ALFA
  55 :       BX=ALFA*(Y(L)*Z(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
  56 :       BY=ALFA*(X(L)*Z(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
  57 :       BZ=ALFA*(X(L)*Y(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
  58 : C
  59 :          FM(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
  60 :          FM(2,L)=X(L)*UNSCO
  61 :          FM(3,L)=Y(L)*UNSCO
  62 :          FM(4,L)=Z(L)*UNSCO
  63 : C
  64 :          FN(1,L)=FM(1,L)*(1.D0-BB)
  65 :          FN(2,L)=FM(2,L)*(1.D0-BB)
  66 :          FN(3,L)=FM(3,L)*(1.D0-BB)
  67 :          FN(4,L)=FM(4,L)*(1.D0-BB)
  68 :          FN(5,L)=BB
  69 : C
  70 :          GR(1,1,L)=-UNSCO*(1.D0-BB)-BX*FM(1,L)
  71 :          GR(2,1,L)=-UNSCO*(1.D0-BB)-BY*FM(1,L)
  72 :          GR(3,1,L)=-UNSCO*(1.D0-BB)-BZ*FM(1,L)
  73 : C
  74 :          GR(1,2,L)=UNSCO*(1.D0-BB)-BX*FM(2,L)
  75 :          GR(2,2,L)=-BY*FM(2,L)
  76 :          GR(3,2,L)=-BZ*FM(2,L)
  77 : C
  78 :          GR(1,3,L)=-BX*FM(3,L)
  79 :          GR(2,3,L)=UNSCO*(1.D0-BB)-BY*FM(3,L)
  80 :          GR(3,3,L)=-BZ*FM(3,L)
  81 : C
  82 :          GR(1,4,L)=-BX*FM(4,L)
  83 :          GR(2,4,L)=-BY*FM(4,L)
  84 :          GR(3,4,L)=UNSCO*(1.D0-BB)-BZ*FM(4,L)
  85 : C
  86 :          GR(1,5,L)=BX
  87 :          GR(2,5,L)=BY
  88 :          GR(3,5,L)=BZ
  89 : C
  90 :          GM(1,1,L)=-UNSCO
  91 :          GM(2,1,L)=-UNSCO
  92 :          GM(3,1,L)=-UNSCO
  93 : C
  94 :          GM(1,2,L)=UNSCO
  95 :          GM(2,2,L)=0.D0
  96 :          GM(3,2,L)=0.D0
  97 : C
  98 :          GM(1,3,L)=0.D0
  99 :          GM(2,3,L)=UNSCO
 100 :          GM(3,3,L)=0.D0
 101 : C
 102 :          GM(1,4,L)=0.D0
 103 :          GM(2,4,L)=0.D0
 104 :          GM(3,4,L)=UNSCO
 105 : C
 106 : 
 107 :  1    CONTINUE
 108 : 
 109 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 110 : C     WRITE(6,100)
 111 : C     WRITE(6,101)
 112 : C     WRITE(6,1002)FN
 113 : C     WRITE(6,1002)GR
 114 : C     WRITE(6,101)
 115 :       RETURN
 116 :  1002 FORMAT(10(1X,1PD11.4))
 117 :  1001 FORMAT(20(1X,I5))
 118 :  100  FORMAT(1H1)
 119 :  101  FORMAT(1X,'... SUB PB403 ... FN,GR,FOM,GM ',9(10H..........)/)
 120 :       END
 121 :  
 122 :  
 123 :  
 124 :  
 125 :  
 126 :  
 127 :