compc.f

Go to the documentation of this file.

      subroutine compc                                                  
c                                                                       
c***********************************************************************
c     include the common statements.....................................
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
c***********************************************************************
c                                                                       
      real * 4 ee(2),qspp(50)                                           
       ee(1) = 0.5                                                      
       ee(2) = 0.5                                                      
      do 20 k=1,(nx-1)
      i=ii                                                              
      qspp(i)=0.                                                        
      do 7 m=1,jpart                                                    
      xfot=const*(ee(1)*(ppin(1,m,i,k)+ppin(5,m,i,k))+
     1            ee(2)*(ppin(2,m,i,k)+ppin(6,m,i,k)))  
c      write(6,150)ii,k,m,ppin(1,m,i,k),ppin(5,m,i,k),
c    1              ppin(2,m,i,k),ppin(6,m,i,k),xfot
150   format('ii,k,pin,xfot',3i3,1x,1p5e11.3)
      if(m.eq.1.or.m.eq.jpart)go to 9                                   
      qspp(i)=qspp(i)+2.*xfot                                           
      go to 6                                                           
    9 qspp(i)=qspp(i)+xfot                                              
    6 continue                                                          
c     write(6,966)i,k,m,ppin(1,m,i,k),ppin(2,m,i,k),const,xfot,qspp(i)
966   format(3i3,1x,1p5e11.3)
7     continue
      sum=qspp(i)*dcmu(i)*ddphi
      qsp(k)=qsp(k)+sum                                                 
c     write(6,100)i,k,qsp(k),sum,qspp(i),dcmu(i),ddphi
100   format('i,k,qsp,sum,qssp,dcmu,dphi',2i3,1p5e9.2)
 20   continue                                                          
      return                                                            
      end                                                               
c***********************************************************************