Esope source files

   1 : C PB401     SOURCE    CHAT      05/01/13    02:10:21     5004           
   2 :       SUBROUTINE PB401(X,PG,FN,GR,FM,GM,ND,NP,MP,NG,NPG,MPG)
   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 : SEG4
   8 : C                                                                               
   9 : C************************************************************************       
  10 :                                                                                 
  11 :       DIMENSION X(NPG)
  12 :       DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG)
  13 :       REAL*8 FM(MP,MPG),GM(ND,MP,MPG)
  14 :       DIMENSION U(5),H(5)
  15 :                                                                                 
  15 :       CALL CALUHG(U,H,NG)                                                       
  16 :       A=0.D0                                                                    
  17 :       B=1.D0                                                                    
  17 :       CALL CALG1(A,B,NG,H,U,X,PG)                                               
  18 :       DO 1 L=1,NPG                                                              
  19 : C                                                                               
  20 :       FN(1,L)=(1.D0-3.D0*X(L))*(2.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  21 :       FN(2,L)=X(L)*(2.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  22 :       FN(3,L)=-X(L)*(1.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  23 :       FN(4,L)=X(L)*(1.D0-3.D0*X(L))*(2.D0-3.D0*X(L))/2.D0
  24 :       GR(1,1,L)=-(1.D0-3.D0*X(L))*(2.D0-3.D0*X(L))/2.D0
  25 :      &          -3.D0*(1.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  26 :      &          -3.D0*(2.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  27 :       GR(1,2,L)=-X(L)*(2.D0-3.D0*X(L))/2.D0
  28 :      &          -3.D0*X(L)*(1.D0-X(L))/2.D0
  29 :      &          +(2.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  30 :       GR(1,3,L)=-X(L)*(1.D0-3.D0*X(L))/2.D0
  31 :      &          +3.D0*X(L)*(1.D0-X(L))/2.D0
  32 :      &          -(1.D0-3.D0*X(L))*(1.D0-X(L))/2.D0
  33 :       GR(1,4,L)=-3.D0*X(L)*(1.D0-3.D0*X(L))/2.D0
  34 :      &          -3.D0*X(L)*(2.D0-3.D0*X(L))/2.D0
  35 :      &          +(1.D0-3.D0*X(L))*(2.D0-3.D0*X(L))/2.D0
  36 :  1    CONTINUE                                                                  
  37 : 
  38 :       IF(MP.EQ.1)THEN
  39 :       DO 2 L=1,MPG
  40 :       FM(1,L)=1.D0
  41 :       GM(1,1,L)=0.D0
  42 :  2    CONTINUE
  43 :       ELSEIF(MP.EQ.3)THEN
  44 :       DO 3 L=1,MPG
  45 :       FM(1,L)= (X(L)-1.D0)*(2.D0*X(L)-1.D0)
  46 :       FM(2,L)=-4.D0*X(L)*(X(L)-1.D0)
  47 :       FM(3,L)=X(L)*(2.D0*X(L)-1.D0)
  48 :  3    CONTINUE
  48 :       CALL INITD(GM,(ND*MP*MPG),0.D0)
  49 : 
  50 :       ENDIF
  51 : 
  52 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
  53 : C     WRITE(6,101)
  54 : C     WRITE(6,1002)FN
  55 : C     WRITE(6,1002)GR
  56 : C     WRITE(6,101)
  57 :       RETURN                                                                    
  58 :  1002 FORMAT(10(1X,1PD11.4))                                                    
  59 :  1001 FORMAT(20(1X,I5))                                                         
  60 :  101  FORMAT(1X,'... SUB PB401 ... FN,GR ',9(10H..........)/)
  61 : C                                                                               
  62 :       END                                                                       
  63 :  
  64 :  
  65 :  
  66 :