      PROGRAM main
      REAL sz, k, r, t, tdiv, div, v (4), rate
      REAL psi, xmu, rho, cbscall, camc, ceur, cams
      INTEGER repb, reps, reps1, i, ii, times, n, nreps1
      REAL timediff, timearray (2), dtime, rtimes
      REAL ss1 (2048, 31), vv1 (2048, 31), uux (2048, 31), ddx (2048, 31
     &), aatmp1 (2048, 31), aatmp2 (2048, 31)
      REAL temp1 (2048), temp2 (2048)
      REAL u, d, dt, r1, tmp1, tmp2, rx, xreps
      INTEGER nproc0
      PARAMETER (nproc0 = 4)
C     DECOMPOSITION FRED (8192)
C     DISTRIBUTE FRED (BLOCK)
C     ALIGN ss1 (i, :) WITH FRED (i)
C     ALIGN vv1 (i, :) WITH FRED (i)
C     ALIGN uux (i, :) WITH FRED (i)
C     ALIGN ddx (i, :) WITH FRED (i)
C     ALIGN aatmp1 (i, :) WITH FRED (i)
C     ALIGN aatmp2 (i, :) WITH FRED (i)
C     ALIGN temp1 (i) WITH FRED (i)
C     ALIGN temp2 (i) WITH FRED (i)
      INTEGER Ti1
      INTEGER Tllb1
      INTEGER Tlub1
      INTEGER minLoc1, maxLoc1, minLoc2, maxLoc2, coord(3)
      COMMON /g_to_l/minLoc1, maxLoc1, minLoc2, maxLoc2, coord
      INTEGER TTT0temp_info (8,7), TTT2temp_info (8,7), Tss1_info (8,7),
     & Ttemp1_info (8,7), Ttemp2_info (8,7)
      INTEGER proclist(8)
      REAL TT0temp (2048)
C      ALIGN TT0temp (i) WITH FRED (i)
      REAL TT2temp (2048)
C      ALIGN TT2temp (i) WITH FRED (i)
      INTEGER TT4temp
      REAL sum_2_R_s
      CALL parameter_for_intrinsic (TTT0temp_info, 1, 1, 2048, 2048, 1, 
     &4)
      CALL parameter_for_intrinsic (TTT2temp_info, 1, 1, 2048, 2048, 1, 
     &4)
      CALL parameter_for_intrinsic (Tss1_info, 1, 1, 2048, 2048, 1, 4)
      CALL parameter_for_intrinsic (Tss1_info, 2, 1, 31, 31, 0, 0)
      CALL parameter_for_intrinsic (Ttemp1_info, 1, 1, 2048, 2048, 1, 4)
      CALL parameter_for_intrinsic (Ttemp2_info, 1, 1, 2048, 2048, 1, 4)
      CALL EXP_init_1 (4, 2048)
      proclist(1)=-1
      k = 100.00
      sz = 110
      repb = 1000
      reps = 17
      psi = 1.0
      xmu = 0.0
      rho = 0.234
      k = 100.00
      r = 4.50
      t = .25
      v (1) = 0.15
      v (2) = 0.15
      v (3) = 0.15
      v (4) = 0.15
      div = 1.0
      tdiv = 0.125
      times = 1
      rtimes = float (times)
      PRINT *, 'stochastic volatility European Model'
      PRINT *, '------------------------------------'
      PRINT *, 'reps         Value       Time(millisec.)'
      DO 7006 reps = 17, 17
      DO 7004 ii = 1, times
      xreps = float (reps)
      dt = t / xreps
      rx = (rate + 1.0) ** dt
      tmp1 = (xmu - 0.5 * psi * psi) * dt
      tmp2 = rho * psi * sqrt (dt)
      u = exp (tmp1 + tmp2)
      d = exp (tmp1 - tmp2)
      TT4temp = 1
      DO Ti1 = 1, 2048
      vv1 (Ti1, 1) = 0.0
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ss1 (Ti1, 1) = 0.0
      END DO
      IF (coord (1) .EQ. 0) vv1 (1, 1) = v (3) * v (3)
      IF (coord (1) .EQ. 0) ss1 (1, 1) = sz
      n = 1
      DO 7000 i = 1, 13
      TT4temp = 1
      DO Ti1 = 1, 2048
      aatmp1 (Ti1, 1) = (rate - 0.5 * vv1 (Ti1, 1)) * dt
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      aatmp2 (Ti1, 1) = sqrt (vv1 (1 + Ti1, 1) * dt)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      uux (Ti1, 1) = exp (aatmp1 (1 + Ti1, 1) + aatmp2 (1 + Ti1, 1))
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ddx (Ti1, 1) = exp (aatmp1 (1 + Ti1, 1) - aatmp2 (1 + Ti1, 1))
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      temp2 (Ti1) = d * vv1 (Ti1, 1)
      END DO
      TT4temp = 1
      CALL eoshift_1_R (temp2, Ttemp2_info (1, 1), Ttemp2_info (2, 1), T
     &temp2_info, - n, TT0temp, TTT0temp_info (1, 1), TTT0temp_info (2, 
     &1), TTT0temp_info, proclist)
      DO Ti1 = 1, 2048
      temp1 (Ti1) = TT0temp (Ti1)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      vv1 (Ti1, 1) = u * vv1 (Ti1, 1) + temp1 (Ti1)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      temp1 (Ti1) = ddx (Ti1, 1) * ss1 (Ti1, 1)
      END DO
      TT4temp = 1
      CALL eoshift_1_R (temp1, Ttemp1_info (1, 1), Ttemp1_info (2, 1), T
     &temp1_info, - n, TT2temp, TTT2temp_info (1, 1), TTT2temp_info (2, 
     &1), TTT2temp_info, proclist)
      DO Ti1 = 1, 2048
      temp2 (Ti1) = TT2temp (Ti1)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ss1 (Ti1, 1) = uux (Ti1, 1) * ss1 (Ti1, 1) + temp2 (Ti1)
      END DO
      n = 2 * n
7000  CONTINUE
      reps1 = reps - 13
      nreps1 = 2 ** (reps1 + 1) - 1
      DO 7002 i = 1, nreps1 / 2
      TT4temp = 1
      DO Ti1 = 1, 2048
      aatmp1 (Ti1, i) = (rate - 0.5 * vv1 (Ti1, i)) * dt
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      aatmp2 (Ti1, i) = sqrt (vv1 (1 + Ti1, i) * dt)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      uux (Ti1, i) = exp (aatmp1 (1 + Ti1, i) + aatmp2 (1 + Ti1, i))
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ddx (Ti1, i) = exp (aatmp1 (1 + Ti1, i) - aatmp2 (1 + Ti1, i))
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      vv1 (Ti1, 2 * i) = u * vv1 (Ti1, i)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      vv1 (Ti1, (2 * i + 1)) = d * vv1 (Ti1, i)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ss1 (Ti1, 2 * i) = uux (Ti1, i) * ss1 (Ti1, i)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ss1 (Ti1, (2 * i + 1)) = ddx (Ti1, i) * ss1 (Ti1, i)
      END DO
      TT4temp = 1
      DO Ti1 = 1, 2048
      ss1 (Ti1, i) = 0.0
      END DO
7002  CONTINUE
      ceur = sum_2_R_s (ss1, Tss1_info (1, 1), Tss1_info (2, 1), Tss1_in
     &fo (1, 2), Tss1_info (2, 2), Tss1_info, proclist) / ((2 * rx) ** x
     &reps)
6000  CONTINUE
7004  CONTINUE
      WRITE (*, '(I3,9X,f9.4,5X,f8.4)') reps, ceur
1111  CONTINUE
7006  CONTINUE
      STOP
      END
