Esope source files

   1 : C PB403     SOURCE    MAGN      10/05/19    21:15:07     6676           
   2 :       SUBROUTINE PB403(XREF,X,Y,Z,PG,FN,GR,FM,GM,ND,NP,MP,NPG,NOM2)
   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 : TET4
   8 : C
   9 : C***********************************************************************
  10 :       CHARACTER*4 NOM2
  11 :       REAL*8 XREF(ND,NP),X(NPG),Y(NPG),Z(NPG)
  12 :       DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG)
  13 :       DIMENSION FM(MP,NPG),GM(ND,MP,NPG)
  14 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  15 :       CO=6.D0 ** (1.D0/3.D0)
  16 :       UNSCO=1.D0/CO
  17 :       XXXX=-1.D0*UNSCO
  18 : C
  19 :       XREF(1,1)=0.D0
  20 :       XREF(2,1)=0.D0
  21 :       XREF(3,1)=0.D0
  22 : 
  23 :       XREF(1,2)=CO
  24 :       XREF(2,2)=0.D0
  25 :       XREF(3,2)=0.D0
  26 : 
  27 :       XREF(1,3)=0.D0
  28 :       XREF(2,3)=CO
  29 :       XREF(3,3)=0.D0
  30 : 
  31 :       XREF(1,4)=0.D0
  32 :       XREF(2,4)=0.D0
  33 :       XREF(3,4)=CO
  34 : C
  35 : 
  36 : C Verification des coordonnées
  37 : C     IF(.TRUE.)THEN
  38 :       IF(.FALSE.)THEN
  39 :       DO 11 L=1,NP
  40 :       X(L)=XREF(1,L)
  41 :       Y(L)=XREF(2,L)
  42 :       Z(L)=XREF(3,L)
  43 :  11   CONTINUE
  44 : 
  45 :       DO 12 L=1,NP
  46 : C
  47 :          FN(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
  48 :          FN(2,L)=X(L)*UNSCO
  49 :          FN(3,L)=Y(L)*UNSCO
  50 :          FN(4,L)=Z(L)*UNSCO
  51 : C
  52 :       write(6,1033)L,FN(1,L),FN(2,L),FN(3,L),FN(4,L)
  53 :  12   CONTINUE
  54 :  1033 FORMAT(1X,I4,' FN',10(1X,1PD11.4))
  55 :       ENDIF
  56 : C Fin Vérification
  57 : 
  58 :       IF(NPG.EQ.1)THEN
  59 :          XXXX=0.25D0*CO
  60 : C
  61 :          X(1)=XXXX
  62 :          Y(1)=XXXX
  63 :          Z(1)=XXXX
  64 :          PG(1)=1.D0
  65 :       ENDIF
  66 :       IF(NPG.EQ.4)THEN
  67 :          AL=.5854101966249684D0*CO
  68 :          BE=.1381966011250105D0*CO
  69 : C
  70 :          X(1)=BE
  71 :          Y(1)=BE
  72 :          Z(1)=BE
  73 :          PG(1)=0.25D0
  74 : C
  75 :          X(2)=AL
  76 :          Y(2)=BE
  77 :          Z(2)=BE
  78 :          PG(2)=0.25D0
  79 : C
  80 :          X(3)=BE
  81 :          Y(3)=AL
  82 :          Z(3)=BE
  83 :          PG(3)=0.25D0
  84 : C
  85 :          X(4)=BE
  86 :          Y(4)=BE
  87 :          Z(4)=AL
  88 :          PG(4)=0.25D0
  89 : C
  90 :       ENDIF
  91 : C
  92 :       DO 1 L=1,NPG
  93 : C
  94 :          FN(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
  95 :          FN(2,L)=X(L)*UNSCO
  96 :          FN(3,L)=Y(L)*UNSCO
  97 :          FN(4,L)=Z(L)*UNSCO
  98 : C
  99 :          GR(1,1,L)=XXXX
 100 :          GR(2,1,L)=XXXX
 101 :          GR(3,1,L)=XXXX
 102 : C
 103 :          GR(1,2,L)=UNSCO
 104 :          GR(2,2,L)=0.D0
 105 :          GR(3,2,L)=0.D0
 106 : C
 107 :          GR(1,3,L)=0.D0
 108 :          GR(2,3,L)=UNSCO
 109 :          GR(3,3,L)=0.D0
 110 : C
 111 :          GR(1,4,L)=0.D0
 112 :          GR(2,4,L)=0.D0
 113 :          GR(3,4,L)=UNSCO
 114 : C
 115 : 
 116 :       IF(NOM2.EQ.'P1P1')THEN
 117 :       FM(1,L)=FN(1,L)
 118 :       FM(2,L)=FN(2,L)
 119 :       FM(3,L)=FN(3,L)
 120 :       FM(4,L)=FN(4,L)
 121 : C
 122 :          GM(1,1,L)=XXXX
 123 :          GM(2,1,L)=XXXX
 124 :          GM(3,1,L)=XXXX
 125 : C
 126 :          GM(1,2,L)=UNSCO
 127 :          GM(2,2,L)=0.D0
 128 :          GM(3,2,L)=0.D0
 129 : C
 130 :          GM(1,3,L)=0.D0
 131 :          GM(2,3,L)=UNSCO
 132 :          GM(3,3,L)=0.D0
 133 : C
 134 :          GM(1,4,L)=0.D0
 135 :          GM(2,4,L)=0.D0
 136 :          GM(3,4,L)=UNSCO
 137 : C
 138 :       ELSE
 139 :       FM(1,L)=1.D0
 140 :       GM(1,1,L)=0.D0
 141 :       GM(2,1,L)=0.D0
 142 :       GM(3,1,L)=0.D0
 143 :       ENDIF
 144 : 
 145 :  1    CONTINUE
 146 : 
 147 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 148 : C     WRITE(6,100)
 149 : C     WRITE(6,101)
 150 : C     WRITE(6,1002)FN
 151 : C     WRITE(6,1002)GR
 152 : C     WRITE(6,101)
 153 :       RETURN
 154 :  1002 FORMAT(10(1X,1PD11.4))
 155 :  1001 FORMAT(20(1X,I5))
 156 :  100  FORMAT(1H1)
 157 :  101  FORMAT(1X,'... SUB PB403 ... FN,GR,FOM,GM ',9(10H..........)/)
 158 :       END
 159 :  
 160 :  
 161 :  
 162 :  
 163 :  
 164 :