c_____________________svcorp3.fcm___________________________
      subroutine svcorp3(s,x,r,t,v,psi,xmu,cor,reps,call)
      implicit none

      real s,x,r,t,v,psi,xmu,cor,call
      integer reps

      real,array(1:2**reps) :: ux,dx,atmp1,atmp2,st
      real,array(0:reps,1:2**reps) :: v1,s1
      integer,array(1:2**reps) :: index,ud

      real u,d,dt,r1,tmp1,tmp2,rx,xreps
      integer i,n,nn,n2

cmf$  layout ux(:news),dx(:news),atmp1(:news),atmp2(:news),ud(:news)
cmf$  layout s1(:serial,:news),v1(:serial,:news),index(:news)

      xreps = float(reps)
      dt = t/xreps
      nn = 2**reps
      forall(i=1:nn) index(i) = i-1

CCCC  SET RX (PERIODIC 1+RF) TO RISK FREE RATE + 1

      rx=(r+1.0)**dt

      tmp1 = (xmu-0.5*psi*psi)*dt
      tmp2 = cor*psi*sqrt(dt) 
      u = exp(tmp1+tmp2)
      d = exp(tmp1-tmp2)

cccc  create stock price lattice (sl)
        
      v1(0,:) = v*v
      s1(0,:) = s 

      n2 = nn/2
      do i = 1,reps
         atmp1 = (xmu-0.5*v1(i-1,:))*dt
         atmp2 = sqrt(v1(i-1,:)*dt)
	 ux = exp(atmp1+atmp2)
         dx = exp(atmp1-atmp2)
         ud = index/n2
         where (mod(ud,2) .eq. 0)
           v1(i,:) = u*v1(i-1,:)
           s1(i,:) = ux*s1(i-1,:)
         elsewhere
           v1(i,:) = d*v1(i-1,:)
           s1(i,:) = dx*s1(i-1,:)
         endwhere
         n2 = n2/2
      enddo

cccc  calculate call price

      st = s1(reps,:) - x

      where (st .lt. 0.0)  st = 0.0
      call = SUM(st)/((2*rx)**xreps)

      return
      end
