!-------------------------------------------------------------------------------
!> Program SCALE-RM Vertical Grid Maker
!!
!! @par Description
!!          This program is make of vertical grid arrangement
!!
!! @author Team SCALE
!!
!<
!-------------------------------------------------------------------------------
program scaleles_make_vgrid
  !-----------------------------------------------------------------------------
  !
  implicit none
  integer :: num_levs             = 50
  integer :: cnst_nlevs_low       = 10
  integer :: cnst_nlevs_mid       = 10
  integer :: cnst_nlevs_upp       = 10
  integer :: nonlinear_nlevs_mid  = 10
  integer :: nonlinear_nlevs_mid2 = 10
  integer :: nonlinear_nlevs_upp  = 10

  real(4) :: top_height           = 16000.D0
  real(4) :: cnst_thick_low       = 100.D0
  real(4) :: nonlinear_rate_mid   = 8.D0
  real(4) :: nonlinear_rate_mid2  = 8.D0
  real(4) :: cnst_thick_mid       = 500.D0
  real(4) :: nonlinear_rate_upp   = 5.D0
  real(4) :: cnst_thick_upp       = 1000.D0
  real(4) :: nonlinear_rate_top   = 3.D0

  logical :: cnst_middle         = .false.
  logical :: nonlinear_top       = .false.
  logical :: force_skip          = .false.

  real(4),       allocatable :: fz   (:)
  real(4),       allocatable :: dz1  (:)
  real(4),       allocatable :: dz2  (:)
  character(2),  allocatable :: label(:)

  integer :: i, is, ie, integ
  real(4) :: work
  !-----------------------------------------------------------------------------

  namelist /make_vgrid/    &
    num_levs,              &
    top_height,            &
    cnst_thick_low,        &
    cnst_nlevs_low,        &
    cnst_thick_mid,        &
    cnst_nlevs_mid,        &
    cnst_thick_upp,        &
    cnst_nlevs_upp,        &
    nonlinear_rate_mid,    &
    nonlinear_nlevs_mid,   &
    nonlinear_rate_mid2,   &
    nonlinear_nlevs_mid2,  &
    nonlinear_nlevs_upp,   &
    nonlinear_rate_upp,    &
    nonlinear_rate_top,    &
    cnst_middle,           &
    nonlinear_top

  open  ( 20, file='vgrid.conf', status='old', delim='apostrophe' )
  read  ( 20, nml=make_vgrid )
  close ( 20 )

  write (*,*) "### SCALE-RM: make setting of vertical grid arrangement"
  write (*,*) "### Prototype 1:"
  write (*,*) "Number of Total Levels:                    ", num_levs
  write (*,*) "Top Height Request (m):                    ", top_height
  write (*,*) "Constant Thickness [Low Level]:            ", cnst_thick_low
  write (*,*) "Number of Constant Levels [Low Level]:     ", cnst_nlevs_low
  write (*,*) "Increasing Rate (%) [Mid Level]:           ", nonlinear_rate_mid
  write (*,*) "Number of Increasing Levels [Mid Level]:   ", nonlinear_nlevs_mid
  write (*,*) "Constant Thickness [Upper Level]:          ", cnst_thick_upp
  write (*,*) "Number of Constant Levels [Upper Level]:   ", cnst_nlevs_upp
  if ( cnst_middle ) then
    write (*,*) "Increasing Rate (%) [Mid Level 2]:         ", nonlinear_rate_mid2
    write (*,*) "Number of Increasing Levels [Mid Level 2]: ", nonlinear_nlevs_mid2
    write (*,*) "Constant Thickness [Mid Level]:            ", cnst_thick_mid
    write (*,*) "Number of Constant Levels [Mid Level]:     ", cnst_nlevs_mid
    write (*,*) "Increasing Rate (%) [Upper Level]:         ", nonlinear_rate_upp
    write (*,*) "Number of Increasing Levels [Upper Level]: ", nonlinear_nlevs_upp
  endif
  if ( nonlinear_top ) then
    write (*,*) "Percent of Increasing (%) [Top Level]:     ", nonlinear_rate_top
  endif
  write (*,*) "Switch for Constant Middle:  ", cnst_middle
  write (*,*) "Switch for Non-linear Top:   ", nonlinear_top
  write (*,*) "------------------------------------------------"

  allocate( fz   (0:num_levs) )
  allocate( dz1  (0:num_levs) )
  allocate( dz2  (0:num_levs) )
  allocate( label(0:num_levs) )

  fz(0) = 0.D0
  integ = 0

  ! setting check
  work = cnst_thick_low * float(cnst_nlevs_low)
  if( work >= top_height )then
     write(*,*) '"Constant Thickness" or "Number of Constant Levels" is not appropriate'
     stop
  endif
  work = cnst_nlevs_low + nonlinear_nlevs_mid + cnst_nlevs_upp
  if( work > num_levs )then
     write(*,*) "Total of Requested Layers is over the num_levs"
     stop
  endif

  ! constant layer [low]
  is = 1
  ie = is + cnst_nlevs_low - 1
  integ = integ + cnst_nlevs_low
  do i=is, ie
     fz(i) = fz(i-1) + cnst_thick_low
     label(i) = "LC"
  enddo

  ! nonlinear layer [mid]
  is = integ + 1
  ie = is + nonlinear_nlevs_mid - 1
  integ = integ + nonlinear_nlevs_mid
  do i=is, ie
     fz(i) = fz(i-1) + (fz(i-1)-fz(i-2))*(nonlinear_rate_mid*1.D-2)
     label(i) = "MN"
     if( fz(i) > top_height ) then
        write(*,*) "Over Shoot [MN]: at",i,fz(i)
        stop
     endif
  enddo

  if ( cnst_middle ) then
     ! nonlinear layer [mid:2] for connect cnst layer
     is = integ + 1
     ie = is + nonlinear_nlevs_mid2 - 1
     integ = integ + nonlinear_nlevs_mid2
     do i=is, ie
        fz(i) = fz(i-1) + (fz(i-1)-fz(i-2))*(nonlinear_rate_mid2*1.D-2)
        label(i) = "M2"
        if( fz(i) > top_height ) then
           write(*,*) "Over Shoot [M2]: at",i,fz(i)
           stop
        endif
     enddo

     ! constant layer [mid]
     is = integ + 1
     ie = is + cnst_nlevs_mid - 1
     integ = integ + cnst_nlevs_mid
     do i=is, ie
        fz(i) = fz(i-1) + cnst_thick_mid
        label(i) = "MC"
     enddo

     ! nonlinear layer [upper]
     is = integ + 1
     ie = is + nonlinear_nlevs_upp - 1
     integ = integ + nonlinear_nlevs_upp
     do i=is, ie
        fz(i) = fz(i-1) + (fz(i-1)-fz(i-2))*(nonlinear_rate_upp*1.D-2)
        label(i) = "UN"
        if( fz(i) > top_height ) then
           write(*,*) "Over Shoot [UN]: at",i,fz(i)
           stop
        endif
     enddo
  endif

  ! constant layer [upper]
  is = integ + 1
  if ( nonlinear_top ) then
     ie = is + cnst_nlevs_upp - 1
  else
     ie = num_levs
  endif
  integ = integ + cnst_nlevs_upp
  if ( ie >= num_levs ) then
     ie = num_levs
     force_skip = .true.
  endif
  do i=is, ie
     fz(i) = fz(i-1) + cnst_thick_upp
     label(i) = "UC"
     if( fz(i) > top_height ) then
        write(*,*) "Over Shoot [UC]: at",i,fz(i)
        stop
     endif
  enddo

  ! nonlinear layer [top]: optional
  if ( force_skip ) then
     write(*,*) "WARNING: Constant Upper Layer has reached top already!"
  else
     if ( nonlinear_top ) then
        is = integ + 1
        ie = num_levs
        do i=is, ie
           work = (fz(i-1)-fz(i-2)) - (fz(i-1)-fz(i-2))*(1.0D0 - nonlinear_rate_top*1.D-2)
           fz(i) = fz(i-1) + work
           label(i) = "TN"
           if( fz(i) > top_height*1.2D0 ) then
              write(*,*) "Over Shoot [TN]: at",i,fz(i)
              stop
           endif
        enddo
     endif
  endif

  dz1(0) = 0.D0
  do i=1, num_levs
     dz1(i) = fz(i) - fz(i-1)
  enddo
  dz2(0) = 0.D0
  dz2(1) = 0.D0
  do i=2, num_levs
     dz2(i) = dz1(i) - dz1(i-1)
  enddo

  write (*,*) "---------------------------------------------------"
  write (*,*) "  z        fz         dz^1         dz^2  process"
  write (*,*) "---------------------------------------------------"
  do i=0, num_levs
     write (*,'(1X,I3,1X,"|",1X,F10.4,2X,F10.4,2X,F10.4,4X,A)') i, fz(i), dz1(i), dz2(i), label(i)
  enddo
  write (*,*) "---------------------------------------------------"

  open  ( 30, file='vgrid_arrangement.txt', form='formatted', status='replace' )
  write ( 30,'(" FZ(:) = ",5(1X,F10.4,"D0,"))' ) fz(1), fz(2), fz(3), fz(4), fz(5)
  do i=6, num_levs, 5
     write ( 30,'("         ",5(1X,F10.4,"D0,"))' ) fz(i), fz(i+1), fz(i+2), fz(i+3), fz(i+4)
  enddo
  close ( 30 )

  open  (31, file='test.txt', form='formatted', status='replace')
  do i=1, num_levs
     write (31,'(1X,I3,2X,F10.4)') i, fz(i)
  enddo
  close (31)

  stop
  !=============================================================================

end program scaleles_make_vgrid


program rutherford_scattering
      use numerical_integration
      implicit none

      integer, parameter :: n_pts = 100
      real(kind=dp), parameter :: Mn = 939.5654133, Mz = 938.2720813
      integer :: Zp, Zt, Np, Nt, Ap, At, i, j, k
      real(kind=dp) :: Mp, Mt, Rt, imp_param, KEp, Vp, dt
      real(kind=dp) :: t_list(n_pts), z(n_pts, 4)

      read(*,*) Zp, Np, Zt, Nt, imp_param

      dt = 100
      Ap = Zp+Np; At = Zt+Nt;
      Mp = Zp*Mz + Np*Mn; Mt = Zt*Mz + Np*Mn;
      Rt = 1.2*At**(1.0d0/3.0d0)
      KEp = 5.0d0
      Vp = sqrt(2*KEp/Mp)

      ! Set inital conditions
      z(1,:) = [-100.0d0, vp, imp_param, 0.0d0]

      call rk4(t_list, z, dt, n_pts, 4, rf_scattering_deriv)

      do i=1, n_pts
        write(*, "(3f14.5)") t_list(i), z(i,1), z(i,3)
      end do

contains
      subroutine rf_scattering_deriv(t, z, dzdt)
              implicit none
              real(kind=dp), intent(in) :: t, z(4)
              real(kind=dp), intent(out) :: dzdt(4)
              real(kind=dp) :: r
              real(kind=dp), parameter :: e2 = 1.44
              integer ::  qQ

              qQ = Zp*Zt
              r = max(sqrt(z(1)*z(1) + z(3)*z(3)), Rt)

              dzdt(1) = z(2); dzdt(3) = z(4);
              dzdt(2) = qQ*e2*z(1)/(Mp*r*r*r)
              dzdt(4) = qQ*e2*z(3)/(Mp*r*r*r)

      end subroutine rf_scattering_deriv

end program rutherford_scattering


      double complex function trI4(p1,p2,p3,p4,s12,s23,
     & m1,m2,m3,m4,mu2,ep)
c--- this is a switchyard routine: depending on value of
c--- integer variable, this routine either:
c---  TRscalarselect = 1    calls QCDLoop for scalar integral
c---  TRscalarselect = 2    calls OneLOop for scalar integral
c---  TRscalarselect = 3    calls both routines and compares results
c      use avh_olo
      implicit none
      include 'TRscalarselect.f'
      double precision p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2
      double complex qlI4,resQCDLoop,resOneLOop,result(0:2)
      integer ep

      TRscalarselect=1

c--- call to QCDLoop if necessary
      if ((TRscalarselect .eq. 1) .or.(TRscalarselect .eq. 3)) then
        resQCDLoop=qlI4(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,ep)
      endif

      if (TRscalarselect .eq. 1) then
        trI4=resQCDLoop
        return
      endif

      call olo_d0(result,p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,dsqrt(mu2))
      resOneLOop=result(abs(ep))
      trI4=resOneLOop

      if (TRscalarselect .eq. 3) then
        if ((cdabs(resOneLOop) .gt. 1d-12) .and.
     &      (abs(resQCDLoop/resOneLOop-1d0) .gt. 1d-12)) then
          write(6,*) 'trI4: ',p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,ep
          write(6,*) 'QCDLoop:',resQCDLoop
          write(6,*) 'OneLOop:',resOneLOop
          write(6,*) '->ratio:',resQCDLoop/resOneLOop
        endif
      endif

      return
      end


include 'vector.f90'

module statistic
use vector
implicit none
contains
  !This subroutine need revision, we will use end, start, each, rather than stat_num.
  subroutine ensemble_average(data_array,energy_array,temp,stat_num,average_value,m,n)

    integer::i,j
    integer::ii,jj
    integer::m,n
    integer::stat_num
    integer::min_num
    real(kind=4)::sum_value
    real(kind=4)::average_value
    real(kind=4),dimension(stat_num)::part_prob
    real(kind=4),dimension(m)::data_array
    real(kind=4),dimension(m)::energy_array
    real(kind=4),dimension(n)::temp
    real(kind=4)::kb

    !f2py intent(in)::stat_num,m,n
    !f2py intent(in)::data_array,energy_array,temp
    !f2py intent(out)::average_value

    kb=3.1668073E-6 !unit in Hartree/K
    if ( m>n ) then
      min_num = n
    elseif ( m<n ) then
      min_num = m
    elseif ( m==n ) then
      min_num = m
    end if
    do i=1,stat_num
      ii=min_num-stat_num+i
      sum_value=0.0
      do j=1,stat_num
        jj=min_num-stat_num+j
        sum_value=sum_value+exp(0.0-(energy_array(jj)/temp(jj)-energy_array(ii)/temp(ii))/kb/27.2114)
      end do
      part_prob(i)=1.0/sum_value
    end do
    average_value=0.0
    do i=1,stat_num
      ii=min_num-stat_num+i
      average_value=average_value+part_prob(i)*data_array(ii)
    end do

    return

  end subroutine

  subroutine numerical_average(data_array, average_value, sigma, m)

    integer::i
    integer::m
    real(kind=4)::s_value, sq_value
    real(kind=4)::average_value, sigma
    real(kind=4),dimension(m)::data_array

    !f2py intent(in)::m
    !f2py intent(in)::data_array
    !f2py intent(out)::average_value, sigma

    s_value = 0.0
    sq_value = 0.0
    do i=1,m
      s_value=s_value+data_array(i)
      sq_value=sq_value+data_array(i)*data_array(i)
    end do

    average_value=s_value/m
    sigma = sqrt(sq_value/m-s_value*s_value/(m*m))

    return

  end subroutine

  subroutine fourier_transform(data_tcf,time_array,freq_array,time_step,intensity_array,m,n)

    integer::m,n
    integer::i,j
    real(kind=4)::pi
    real(kind=4)::sum_value
    real(kind=4)::time_step
    real(kind=4)::freq_in_hz
    real(kind=4)::wave_num_to_hz
    real(kind=4),dimension(m)::data_tcf
    real(kind=4),dimension(m)::time_array
    real(kind=4),dimension(m)::time_in_s
    real(kind=4),dimension(n)::freq_array
    real(kind=4),dimension(n)::intensity_array

    !f2py intent(in)::m,n
    !f2py intent(in)::time_step
    !f2py intent(in)::freq_array
    !f2py intent(in)::time_array,data_tcf
    !f2py intent(out)::intensity_array

    pi=3.1415926
    wave_num_to_hz=29979245800.0
    do i=1,m
      time_in_s(i)=time_array(i)*1.0E-15
    end do
    do i=1,n
      freq_in_hz=freq_array(i)*wave_num_to_hz
      sum_value=0.0
      do j=1,m
        sum_value=sum_value+data_tcf(j)*cos(2*pi*freq_in_hz*time_in_s(j))*time_step
      end do
      intensity_array(i)=sum_value
    end do

    return

  end subroutine fourier_transform

  subroutine matrix_element_sum(matrix, index_1, index_2, sum_dim, matrix_sum, u, v, w)

    integer::i,j,k
    integer::u,v,w
    integer::sum_dim
    integer::index_1,index_2
    real(kind=4)::sum_value
    real(kind=4),dimension(sum_dim)::matrix_sum
    real(kind=4),dimension(u,v,w)::matrix

    !f2py intent(in)::u,v,w
    !f2py intent(in)::sum_dim
    !f2py intent(in)::index_1, index_2
    !f2py intent(in)::matrix
    !f2py intent(out)::matrix_sum

    if ( index_1 == 1 .and. index_2 == 2 ) then
      do i=1,w
        sum_value = 0.0
        do j=1,u
          do k=1,v
            sum_value = sum_value + matrix(j,k,i)
          end do
        end do
        matrix_sum(i) = sum_value/(u*v)
     end do

    elseif ( index_1 == 1 .and. index_2 == 3 ) then
      do i=1,v
        sum_value = 0.0
        do j=1,u
          do k=1,w
            sum_value = sum_value + matrix(j,i,k)
          end do
        end do
        matrix_sum(i) = sum_value/(u*w)
     end do

    elseif ( index_1 == 2 .and. index_2 == 3 ) then
      do i=1,u
        sum_value = 0.0
        do j=1,v
          do k=1,w
            sum_value = sum_value + matrix(i,j,k)
          end do
        end do
        matrix_sum(i) = sum_value/(v*w)
      end do
    end if

    return

  end subroutine matrix_element_sum

  subroutine data_mode(cluster_pos,cluster_vel,a_vec,b_vec,c_vec,mass,Q_mode_1,Q_mode_2,Q_mode_3,m,n)

    ! Reference: P. Bopp, Chem. Phys. 1986, 106, 205-212

    integer::i,j
    integer::m,n
    real(kind=4)::sign_value_a,sign_value_b,sign_value_c
    real(kind=4)::a_vec_len,b_vec_len,c_vec_len
    real(kind=4)::proj_a_vec_len,proj_b_vec_len,proj_c_vec_len
    real(kind=4),dimension(n)::v1,v2
    real(kind=4),dimension(n)::distance_xyz
    real(kind=4),dimension(n)::a_vec,b_vec,c_vec
    real(kind=4),dimension(n)::a_vec_basis,b_vec_basis,c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec,proj_b_vec,proj_c_vec
    real(kind=4),dimension(n)::v1_norm,v2_norm
    real(kind=4),dimension(n)::cross_1,cross_1_norm
    real(kind=4),dimension(n)::vel_com
    real(kind=4),dimension(n)::cluster_vel_2,cluster_vel_3
    real(kind=4),dimension(n)::vel2_sub_com,vel3_sub_com
    real(kind=4),dimension(n)::vel2_per,vel3_per
    real(kind=4),dimension(n)::vel2_plane,vel3_plane
    real(kind=4),dimension(n)::vel2_proj_u1,vel3_proj_u2
    real(kind=4),dimension(n)::vel2_proj_w1,vel3_proj_w2
    real(kind=4),dimension(m)::mass
    real(kind=4),dimension(2,n)::vec
    real(kind=4),dimension(m,n)::cluster_pos
    real(kind=4),dimension(m,n)::cluster_vel
    real(kind=4),dimension(n)::Q_mode_1,Q_mode_2,Q_mode_3

    !f2py intent(in)::m,n
    !f2py intent(in)::mass
    !f2py intent(in)::a_vec,b_vec,c_vec
    !f2py intent(in)::cluster_pos,cluster_vel
    !f2py intent(out)::Q_mode_1,Q_mode_2,Q_mode_3

    call get_vec_len(a_vec, a_vec_len, n)
    call get_vec_len(b_vec, b_vec_len, n)
    call get_vec_len(c_vec, c_vec_len, n)

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    do i=1,2
      do j=1,n
        distance_xyz(j) = cluster_pos(i+1,j)-cluster_pos(1,j)
      end do

      call project_vec(distance_xyz, a_vec_basis, n, proj_a_vec, sign_value_a)
      call project_vec(distance_xyz, b_vec_basis, n, proj_b_vec, sign_value_b)
      call project_vec(distance_xyz, c_vec_basis, n, proj_c_vec, sign_value_c)

      call get_vec_len(proj_a_vec, proj_a_vec_len, n)
      call get_vec_len(proj_b_vec, proj_b_vec_len, n)
      call get_vec_len(proj_c_vec, proj_c_vec_len, n)

      if ( proj_a_vec_len > a_vec_len/2 ) then
        proj_a_vec_len = a_vec_len - proj_a_vec_len
        sign_value_a = -sign_value_a
      end if
      if ( proj_b_vec_len > b_vec_len/2 ) then
        proj_b_vec_len = b_vec_len - proj_b_vec_len
        sign_value_b = -sign_value_b
      end if
      if ( proj_c_vec_len > c_vec_len/2 ) then
        proj_c_vec_len = c_vec_len - proj_c_vec_len
        sign_value_c = -sign_value_c
      end if

      distance_xyz = proj_a_vec_len*a_vec_basis*sign_value_a + &
                     proj_b_vec_len*b_vec_basis*sign_value_b + &
                     proj_c_vec_len*c_vec_basis*sign_value_c

      do j=1,n
        vec(i,j) = distance_xyz(j)
      end do
    end do

    do i=1,n
      v1(i)=vec(1,i)
      v2(i)=vec(2,i)
    end do

!    do i=1,n
!      v1(i) = cluster_pos(2,i)-cluster_pos(1,i)
!      v2(i) = cluster_pos(3,i)-cluster_pos(1,i)
!    end do
!    write(*,*)v1,v2

    call norm_vec(v1, v1_norm, n)
    call norm_vec(v2, v2_norm, n)
    call get_vec_cross(v1, v2, n, cross_1)
    call norm_vec(cross_1, cross_1_norm, n)

    call center_of_mass(mass,cluster_vel,vel_com,m,n)

    do i=1,n
      cluster_vel_2(i)=cluster_vel(2,i)
      cluster_vel_3(i)=cluster_vel(3,i)
    end do

    vel2_sub_com=cluster_vel_2-vel_com
    vel3_sub_com=cluster_vel_3-vel_com

    call project_vec(vel2_sub_com,cross_1_norm,n,vel2_per,sign_value_a)
    call project_vec(vel3_sub_com,cross_1_norm,n,vel3_per,sign_value_b)

    vel2_plane=vel2_sub_com-vel2_per
    vel3_plane=vel3_sub_com-vel3_per

    call project_vec(vel2_plane,v1_norm,n,vel2_proj_u1,sign_value_a)
    vel2_proj_w1=vel2_plane-vel2_proj_u1
    call project_vec(vel3_plane,v2_norm,n,vel3_proj_u2,sign_value_b)
    vel3_proj_w2=vel3_plane-vel3_proj_u2

!    Q_mode_1 = vel2_proj_u1*sign_value_a+vel3_proj_u2*sign_value_b
    Q_mode_1 = vel2_proj_u1+vel3_proj_u2
    Q_mode_2 = vel2_proj_w1+vel3_proj_w2
!    Q_mode_3 = vel2_proj_u1*sign_value_a-vel3_proj_u2*sign_value_b
    Q_mode_3 = vel2_proj_u1-vel3_proj_u2

    return

  end subroutine data_mode

end module statistic


submodule (complex_transform_routines) multiple_complex_forward

contains

    module subroutine cfftmf(lot, jump, n, inc, c, lenc, wsave, lensav, work, lenwrk, ierror)
        !
        ! cfftmf: complex forward fft, 1d, multiple vectors.
        !
        !  Purpose:
        !
        !  cfftmf computes the one-dimensional fourier transform of multiple
        !  periodic sequences within a complex array. this transform is referred
        !  to as the forward transform or fourier analysis, transforming the
        !  sequences from physical to spectral space. this transform is
        !  normalized since a call to cfftmf followed by a call to cfftmb
        !  (or vice-versa) reproduces the original array within roundoff error.
        !
        !  the parameters integers inc, jump, n and lot are consistent if equality
        !  i1*inc + j1*jump = i2*inc + j2*jump for i1,i2 < n and j1,j2 < lot
        !  implies i1=i2 and j1=j2. for multiple ffts to execute correctly,
        !  input variables inc, jump, n and lot must be consistent, otherwise
        !  at least one array element mistakenly is transformed more than once.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be
        !  transformed within array c.
        !
        !  integer jump, the increment between the locations,
        !  in array c, of the first elements of two consecutive sequences to be
        !  transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array c, of two consecutive elements within the same sequence to be
        !  transformed.
        !
        !  input/output, complex (wp) c(lenc), array containing lot sequences,
        !  each having length n, to be transformed.  c can have any number of
        !  dimensions, but the total number of locations must be at least lenc.
        !
        !  integer lenc, the dimension of the c array.
        !  lenc must be at least (lot-1)*jump + inc*(n-1) + 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to cfftmi before the first call to routine cfftmf
        !  or cfftmb for a given transform length n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least 2*lot*n.
        !
        !  integer ierror, error_flag.
        !  0 successful exit;
        !  1 input parameter lenc not big enough;
        !  2 input parameter lensav not big enough;
        !  3 input parameter lenwrk not big enough;
        !  4 input parameters inc, jump, n, lot are not consistent.
        !
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip) lot
        integer (ip) jump
        integer (ip) n
        integer (ip) inc
        real(wp) c(2,lenc)
        integer (ip) lenc
        real (wp) wsave(lensav)
        integer (ip) lensav
        real (wp) work(lenwrk)
        integer (ip) lenwrk
        integer (ip) ierror
        !--------------------------------------------------
        ! Local variables
        !--------------------------------------------------
        integer (ip) iw1, iw2
        !--------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lenc < (lot-1)*jump + inc*(n-1) + 1) then
            ierror = 1
            call fft_error_handler('cfftmf ', 6)
        else if (lensav < get_complex_nd_saved_workspace_length(n)) then
            ierror = 2
            call fft_error_handler('cfftmf ', 8)
        else if (lenwrk < get_complex_nd_workspace_length(n, lot)) then
            ierror = 3
            call fft_error_handler('cfftmf ', 10)
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ierror = 4
            call fft_error_handler('cfftmf ', -1)
        else
            ierror = 0
        end if

        !
        !==> Perform transform
        !
        if (n == 1) return

        ! Set workspace index pointer
        iw1 = 2*n+1
        iw2 = iw1 + 1

        call cmfm1f(lot,jump,n,inc,c,work,wsave,wsave(iw1),wsave(iw2))

    end subroutine cfftmf

    subroutine cmfm1f(lot, jump, n, inc, c, ch, wa, fnf, fac)
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        real (wp) c(2,*)
        real (wp) ch(*)
        real (wp) fac(*)
        real (wp) fnf
        integer (ip) ido
        integer (ip) inc
        integer (ip) iip
        integer (ip) iw
        integer (ip) jump
        integer (ip) k1
        integer (ip) l1
        integer (ip) l2
        integer (ip) lid
        integer (ip) lot
        integer (ip) n
        integer (ip) na
        integer (ip) nbr
        integer (ip) nf
        real (wp) wa(*)

        nf = int(fnf, kind=ip)
        na = 0
        l1 = 1
        iw = 1

        do k1=1,nf
            iip = int(fac(k1), kind=ip)
            l2 = iip*l1
            ido = n/l2
            lid = l1*ido
            nbr = 1+na+2*min(iip-2,4)
            select case (nbr)
                case (1)
                    call cmf2kf(lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw))
                case (2)
                    call cmf2kf(lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw))
                case (3)
                    call cmf3kf(lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw))
                case (4)
                    call cmf3kf(lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw))
                case (5)
                    call cmf4kf(lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw))
                case (6)
                    call cmf4kf(lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw))
                case (7)
                    call cmf5kf(lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw))
                case (8)
                    call cmf5kf(lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw))
                case (9)
                    call cmfgkf(lot,ido,iip,l1,lid,na,c,c,jump,inc,ch,ch,1,lot,wa(iw))
                case (10)
                    call cmfgkf(lot,ido,iip,l1,lid,na,ch,ch,1,lot,c,c, &
                        jump,inc,wa(iw))
            end select

            l1 = l2
            iw = iw+(iip-1)*(2*ido)

            if (iip <= 5) na = 1-na
        end do

    end subroutine cmfm1f

    subroutine cmf2kf(lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa)
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1
        real (wp) cc(2,in1,l1,ido,2)

        real (wp) ch(2,in2,l1,2,ido)
        real (wp) chold1
        real (wp) chold2

        integer (ip) i
        integer (ip) im1
        integer (ip) im2
        integer (ip) k

        integer (ip) lot
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s

        integer (ip) na
        real (wp) sn
        real (wp) ti2
        real (wp) tr2
        real (wp) wa(ido,1,2)

        m1d = (lot-1)*im1+1
        m2s = 1-im2

        if (1 >= ido) then
            sn = ONE/(2 * l1)
            if (na /= 1) then
                do k=1,l1
                    do m1=1,m1d,im1
                        chold1 = sn*(cc(1,m1,k,1,1)+cc(1,m1,k,1,2))
                        cc(1,m1,k,1,2) = sn*(cc(1,m1,k,1,1)-cc(1,m1,k,1,2))
                        cc(1,m1,k,1,1) = chold1
                        chold2 = sn*(cc(2,m1,k,1,1)+cc(2,m1,k,1,2))
                        cc(2,m1,k,1,2) = sn*(cc(2,m1,k,1,1)-cc(2,m1,k,1,2))
                        cc(2,m1,k,1,1) = chold2
                    end do
                end do
            else
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+cc(1,m1,k,1,2))
                        ch(1,m2,k,2,1) = sn*(cc(1,m1,k,1,1)-cc(1,m1,k,1,2))
                        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+cc(2,m1,k,1,2))
                        ch(2,m2,k,2,1) = sn*(cc(2,m1,k,1,1)-cc(2,m1,k,1,2))
                    end do
                end do
            end if
        else
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2)
                    ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2)
                    ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2)
                    ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2)
                end do
            end do

            do i=2,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
                        tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
                        ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
                        ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
                        ch(2,m2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2
                        ch(1,m2,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2
                    end do
                end do
            end do
        end if

    end subroutine cmf2kf

    subroutine cmf3kf(lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(2,in1,l1,ido,3)
        real (wp) ch(2,in2,l1,3,ido)
        real (wp) ci2
        real (wp) ci3
        real (wp) cr2
        real (wp) cr3
        real (wp) di2
        real (wp) di3
        real (wp) dr2
        real (wp) dr3
        integer (ip) i
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) lot
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        integer (ip) na
        real (wp) sn
        real (wp), parameter :: taui = -0.866025403784439_wp
        real (wp), parameter :: taur = -HALF
        real (wp) ti2
        real (wp) tr2
        real (wp) wa(ido,2,2)

        m1d = (lot-1)*im1+1
        m2s = 1-im2

        if (1 >= ido) then
            sn = ONE/(3 * l1)
            if (na /= 1) then
                do k=1,l1
                    do m1=1,m1d,im1
                        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
                        cr2 = cc(1,m1,k,1,1)+taur*tr2
                        cc(1,m1,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
                        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
                        ci2 = cc(2,m1,k,1,1)+taur*ti2
                        cc(2,m1,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
                        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
                        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
                        cc(1,m1,k,1,2) = sn*(cr2-ci3)
                        cc(1,m1,k,1,3) = sn*(cr2+ci3)
                        cc(2,m1,k,1,2) = sn*(ci2+cr3)
                        cc(2,m1,k,1,3) = sn*(ci2-cr3)
                    end do
                end do
            else
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
                        cr2 = cc(1,m1,k,1,1)+taur*tr2
                        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
                        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
                        ci2 = cc(2,m1,k,1,1)+taur*ti2
                        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
                        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
                        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
                        ch(1,m2,k,2,1) = sn*(cr2-ci3)
                        ch(1,m2,k,3,1) = sn*(cr2+ci3)
                        ch(2,m2,k,2,1) = sn*(ci2+cr3)
                        ch(2,m2,k,3,1) = sn*(ci2-cr3)
                    end do
                end do
            end if
        else
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
                    cr2 = cc(1,m1,k,1,1)+taur*tr2
                    ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
                    ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
                    ci2 = cc(2,m1,k,1,1)+taur*ti2
                    ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
                    cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
                    ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
                    ch(1,m2,k,2,1) = cr2-ci3
                    ch(1,m2,k,3,1) = cr2+ci3
                    ch(2,m2,k,2,1) = ci2+cr3
                    ch(2,m2,k,3,1) = ci2-cr3
                end do
            end do
            do i=2,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
                        cr2 = cc(1,m1,k,i,1)+taur*tr2
                        ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
                        ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
                        ci2 = cc(2,m1,k,i,1)+taur*ti2
                        ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
                        cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
                        ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
                        dr2 = cr2-ci3
                        dr3 = cr2+ci3
                        di2 = ci2+cr3
                        di3 = ci2-cr3
                        ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
                        ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
                        ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
                        ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
                    end do
                end do
            end do
        end if

    end subroutine cmf3kf

    subroutine cmf4kf(lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(2,in1,l1,ido,4)
        real (wp) ch(2,in2,l1,4,ido)
        real (wp) ci2
        real (wp) ci3
        real (wp) ci4
        real (wp) cr2
        real (wp) cr3
        real (wp) cr4
        integer (ip) i
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) lot
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        integer (ip) na
        real (wp) sn
        real (wp) ti1
        real (wp) ti2
        real (wp) ti3
        real (wp) ti4
        real (wp) tr1
        real (wp) tr2
        real (wp) tr3
        real (wp) tr4
        real (wp) wa(ido,3,2)

        m1d = (lot-1)*im1+1
        m2s = 1-im2

        if (1 >= ido) then
            sn = ONE /(4 * l1)
            if (na /= 1) then
                do k=1,l1
                    do m1=1,m1d,im1
                        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
                        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
                        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
                        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
                        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
                        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
                        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
                        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
                        cc(1,m1,k,1,1) = sn*(tr2+tr3)
                        cc(1,m1,k,1,3) = sn*(tr2-tr3)
                        cc(2,m1,k,1,1) = sn*(ti2+ti3)
                        cc(2,m1,k,1,3) = sn*(ti2-ti3)
                        cc(1,m1,k,1,2) = sn*(tr1+tr4)
                        cc(1,m1,k,1,4) = sn*(tr1-tr4)
                        cc(2,m1,k,1,2) = sn*(ti1+ti4)
                        cc(2,m1,k,1,4) = sn*(ti1-ti4)
                    end do
                end do
            else
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
                        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
                        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
                        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
                        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
                        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
                        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
                        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
                        ch(1,m2,k,1,1) = sn*(tr2+tr3)
                        ch(1,m2,k,3,1) = sn*(tr2-tr3)
                        ch(2,m2,k,1,1) = sn*(ti2+ti3)
                        ch(2,m2,k,3,1) = sn*(ti2-ti3)
                        ch(1,m2,k,2,1) = sn*(tr1+tr4)
                        ch(1,m2,k,4,1) = sn*(tr1-tr4)
                        ch(2,m2,k,2,1) = sn*(ti1+ti4)
                        ch(2,m2,k,4,1) = sn*(ti1-ti4)
                    end do
                end do
            end if
        else
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
                    ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
                    tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
                    ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
                    tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
                    tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
                    ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
                    tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
                    ch(1,m2,k,1,1) = tr2+tr3
                    ch(1,m2,k,3,1) = tr2-tr3
                    ch(2,m2,k,1,1) = ti2+ti3
                    ch(2,m2,k,3,1) = ti2-ti3
                    ch(1,m2,k,2,1) = tr1+tr4
                    ch(1,m2,k,4,1) = tr1-tr4
                    ch(2,m2,k,2,1) = ti1+ti4
                    ch(2,m2,k,4,1) = ti1-ti4
                end do
            end do
            do i=2,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
                        ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
                        ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
                        tr4 = cc(2,m1,k,i,2)-cc(2,m1,k,i,4)
                        tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
                        tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
                        ti4 = cc(1,m1,k,i,4)-cc(1,m1,k,i,2)
                        tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
                        ch(1,m2,k,1,i) = tr2+tr3
                        cr3 = tr2-tr3
                        ch(2,m2,k,1,i) = ti2+ti3
                        ci3 = ti2-ti3
                        cr2 = tr1+tr4
                        cr4 = tr1-tr4
                        ci2 = ti1+ti4
                        ci4 = ti1-ti4
                        ch(1,m2,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
                        ch(2,m2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
                        ch(1,m2,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
                        ch(2,m2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
                        ch(1,m2,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
                        ch(2,m2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
                    end do
                end do
            end do
        end if

    end subroutine cmf4kf

    subroutine cmf5kf(lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) l1

        real (wp) cc(2,in1,l1,ido,5)
        real (wp) ch(2,in2,l1,5,ido)
        real (wp) chold1
        real (wp) chold2
        real (wp) ci2
        real (wp) ci3
        real (wp) ci4
        real (wp) ci5
        real (wp) cr2
        real (wp) cr3
        real (wp) cr4
        real (wp) cr5
        real (wp) di2
        real (wp) di3
        real (wp) di4
        real (wp) di5
        real (wp) dr2
        real (wp) dr3
        real (wp) dr4
        real (wp) dr5
        integer (ip) i
        integer (ip) im1
        integer (ip) im2
        integer (ip) k
        integer (ip) lot
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        integer (ip) na
        real (wp) sn
        real (wp) ti2
        real (wp) ti3
        real (wp) ti4
        real (wp) ti5
        real (wp) tr2
        real (wp) tr3
        real (wp) tr4
        real (wp) tr5

        real (wp), parameter :: SQRT5 = sqrt(FIVE)
        real (wp), parameter :: SQRT5_PLUS_5 = SQRT5 + FIVE
        real (wp), parameter :: TI11 = -sqrt(SQRT5_PLUS_5/2)/2             !-0.9510565162951536_wp
        real (wp), parameter :: TI12 = -sqrt(FIVE/(TWO*SQRT5_PLUS_5)) !-0.5877852522924731_wp
        real (wp), parameter :: TR11 =  (SQRT5 - ONE)/4                 ! 0.3090169943749474_wp
        real (wp), parameter :: TR12 = -(ONE + SQRT5)/4                 !-0.8090169943749474_wp

        real (wp) wa(ido,4,2)

        m1d = (lot-1)*im1+1
        m2s = 1-im2

        if (1 >= ido) then
            sn = ONE/(5 * l1)
            if (na /= 1) then
                do k=1,l1
                    do m1=1,m1d,im1
                        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
                        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
                        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
                        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
                        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
                        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
                        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
                        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
                        chold1 = sn*(cc(1,m1,k,1,1)+tr2+tr3)
                        chold2 = sn*(cc(2,m1,k,1,1)+ti2+ti3)
                        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
                        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
                        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
                        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
                        cc(1,m1,k,1,1) = chold1
                        cc(2,m1,k,1,1) = chold2
                        cr5 = ti11*tr5+ti12*tr4
                        ci5 = ti11*ti5+ti12*ti4
                        cr4 = ti12*tr5-ti11*tr4
                        ci4 = ti12*ti5-ti11*ti4
                        cc(1,m1,k,1,2) = sn*(cr2-ci5)
                        cc(1,m1,k,1,5) = sn*(cr2+ci5)
                        cc(2,m1,k,1,2) = sn*(ci2+cr5)
                        cc(2,m1,k,1,3) = sn*(ci3+cr4)
                        cc(1,m1,k,1,3) = sn*(cr3-ci4)
                        cc(1,m1,k,1,4) = sn*(cr3+ci4)
                        cc(2,m1,k,1,4) = sn*(ci3-cr4)
                        cc(2,m1,k,1,5) = sn*(ci2-cr5)
                    end do
                end do
            else
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
                        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
                        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
                        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
                        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
                        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
                        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
                        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
                        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2+tr3)
                        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2+ti3)
                        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
                        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
                        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
                        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
                        cr5 = ti11*tr5+ti12*tr4
                        ci5 = ti11*ti5+ti12*ti4
                        cr4 = ti12*tr5-ti11*tr4
                        ci4 = ti12*ti5-ti11*ti4
                        ch(1,m2,k,2,1) = sn*(cr2-ci5)
                        ch(1,m2,k,5,1) = sn*(cr2+ci5)
                        ch(2,m2,k,2,1) = sn*(ci2+cr5)
                        ch(2,m2,k,3,1) = sn*(ci3+cr4)
                        ch(1,m2,k,3,1) = sn*(cr3-ci4)
                        ch(1,m2,k,4,1) = sn*(cr3+ci4)
                        ch(2,m2,k,4,1) = sn*(ci3-cr4)
                        ch(2,m2,k,5,1) = sn*(ci2-cr5)
                    end do
                end do
            end if
        else
            do k=1,l1
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
                    ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
                    ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
                    ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
                    tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
                    tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
                    tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
                    tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
                    ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
                    ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
                    cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
                    ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
                    cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
                    ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
                    cr5 = ti11*tr5+ti12*tr4
                    ci5 = ti11*ti5+ti12*ti4
                    cr4 = ti12*tr5-ti11*tr4
                    ci4 = ti12*ti5-ti11*ti4
                    ch(1,m2,k,2,1) = cr2-ci5
                    ch(1,m2,k,5,1) = cr2+ci5
                    ch(2,m2,k,2,1) = ci2+cr5
                    ch(2,m2,k,3,1) = ci3+cr4
                    ch(1,m2,k,3,1) = cr3-ci4
                    ch(1,m2,k,4,1) = cr3+ci4
                    ch(2,m2,k,4,1) = ci3-cr4
                    ch(2,m2,k,5,1) = ci2-cr5
                end do
            end do
            do i=2,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
                        ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
                        ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
                        ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
                        tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
                        tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
                        tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
                        tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
                        ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
                        ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
                        cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
                        ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
                        cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
                        ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
                        cr5 = ti11*tr5+ti12*tr4
                        ci5 = ti11*ti5+ti12*ti4
                        cr4 = ti12*tr5-ti11*tr4
                        ci4 = ti12*ti5-ti11*ti4
                        dr3 = cr3-ci4
                        dr4 = cr3+ci4
                        di3 = ci3+cr4
                        di4 = ci3-cr4
                        dr5 = cr2+ci5
                        dr2 = cr2-ci5
                        di5 = ci2-cr5
                        di2 = ci2+cr5
                        ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
                        ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
                        ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
                        ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
                        ch(1,m2,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
                        ch(2,m2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
                        ch(1,m2,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
                        ch(2,m2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
                    end do
                end do
            end do
        end if

    end subroutine cmf5kf

    subroutine cmfgkf(lot, ido, iip, l1, lid, na, cc, cc1, im1, in1, &
        ch, ch1, im2, in2, wa)

        integer (ip) ido
        integer (ip) in1
        integer (ip) in2
        integer (ip) iip
        integer (ip) l1
        integer (ip) lid

        real (wp) cc(2,in1,l1,iip,ido)
        real (wp) cc1(2,in1,lid,iip)
        real (wp) ch(2,in2,l1,ido,iip)
        real (wp) ch1(2,in2,lid,iip)
        real (wp) chold1
        real (wp) chold2
        integer (ip) i
        integer (ip) idlj
        integer (ip) im1
        integer (ip) im2
        integer (ip) iipp2
        integer (ip) iipph
        integer (ip) j
        integer (ip) jc
        integer (ip) k
        integer (ip) ki
        integer (ip) l
        integer (ip) lc
        integer (ip) lot
        integer (ip) m1
        integer (ip) m1d
        integer (ip) m2
        integer (ip) m2s
        integer (ip) na
        real (wp) sn
        real (wp) wa(ido,iip-1,2)
        real (wp) wai
        real (wp) war

        m1d = (lot-1)*im1+1
        m2s = 1-im2
        iipp2 = iip+2
        iipph = (iip+1)/2

        do  ki=1,lid
            m2 = m2s
            do m1=1,m1d,im1
                m2 = m2+im2
                ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
                ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
            end do
        end do

        do j=2,iipph
            jc = iipp2-j
            do ki=1,lid
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch1(1,m2,ki,j) =  cc1(1,m1,ki,j)+cc1(1,m1,ki,jc)
                    ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)-cc1(1,m1,ki,jc)
                    ch1(2,m2,ki,j) =  cc1(2,m1,ki,j)+cc1(2,m1,ki,jc)
                    ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(2,m1,ki,jc)
                end do
            end do
        end do

        do j=2,iipph
            do ki=1,lid
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    cc1(1,m1,ki,1) = cc1(1,m1,ki,1)+ch1(1,m2,ki,j)
                    cc1(2,m1,ki,1) = cc1(2,m1,ki,1)+ch1(2,m2,ki,j)
                end do
            end do
        end do

        do l=2,iipph
            lc = iipp2-l
            do ki=1,lid
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    cc1(1,m1,ki,l) = ch1(1,m2,ki,1)+wa(1,l-1,1)*ch1(1,m2,ki,2)
                    cc1(1,m1,ki,lc) = -wa(1,l-1,2)*ch1(1,m2,ki,iip)
                    cc1(2,m1,ki,l) = ch1(2,m2,ki,1)+wa(1,l-1,1)*ch1(2,m2,ki,2)
                    cc1(2,m1,ki,lc) = -wa(1,l-1,2)*ch1(2,m2,ki,iip)
                end do
            end do
            do j=3,iipph
                jc = iipp2-j
                idlj = mod((l-1)*(j-1),iip)
                war = wa(1,idlj,1)
                wai = -wa(1,idlj,2)
                do ki=1,lid
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc1(1,m1,ki,l) = cc1(1,m1,ki,l)+war*ch1(1,m2,ki,j)
                        cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc)+wai*ch1(1,m2,ki,jc)
                        cc1(2,m1,ki,l) = cc1(2,m1,ki,l)+war*ch1(2,m2,ki,j)
                        cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc)+wai*ch1(2,m2,ki,jc)
                    end do
                end do
            end do
        end do

        if (1 >= ido) then
            sn = ONE /(iip * l1)
            if (na /= 1) then
                do ki=1,lid
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc1(1,m1,ki,1) = sn*cc1(1,m1,ki,1)
                        cc1(2,m1,ki,1) = sn*cc1(2,m1,ki,1)
                    end do
                end do
                do j=2,iipph
                    jc = iipp2-j
                    do ki=1,lid
                        do m1=1,m1d,im1
                            chold1 = sn*(cc1(1,m1,ki,j)-cc1(2,m1,ki,jc))
                            chold2 = sn*(cc1(1,m1,ki,j)+cc1(2,m1,ki,jc))
                            cc1(1,m1,ki,j) = chold1
                            cc1(2,m1,ki,jc) = sn*(cc1(2,m1,ki,j)-cc1(1,m1,ki,jc))
                            cc1(2,m1,ki,j) = sn*(cc1(2,m1,ki,j)+cc1(1,m1,ki,jc))
                            cc1(1,m1,ki,jc) = chold2
                        end do
                    end do
                end do
            else
                do ki=1,lid
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch1(1,m2,ki,1) = sn*cc1(1,m1,ki,1)
                        ch1(2,m2,ki,1) = sn*cc1(2,m1,ki,1)
                    end do
                end do
                do j=2,iipph
                    jc = iipp2-j
                    do ki=1,lid
                        m2 = m2s
                        do m1=1,m1d,im1
                            m2 = m2+im2
                            ch1(1,m2,ki,j) = sn*(cc1(1,m1,ki,j)-cc1(2,m1,ki,jc))
                            ch1(2,m2,ki,j) = sn*(cc1(2,m1,ki,j)+cc1(1,m1,ki,jc))
                            ch1(1,m2,ki,jc) = sn*(cc1(1,m1,ki,j)+cc1(2,m1,ki,jc))
                            ch1(2,m2,ki,jc) = sn*(cc1(2,m1,ki,j)-cc1(1,m1,ki,jc))
                        end do
                    end do
                end do
            end if
        else
            do ki=1,lid
                m2 = m2s
                do m1=1,m1d,im1
                    m2 = m2+im2
                    ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
                    ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
                end do
            end do
            do j=2,iipph
                jc = iipp2-j
                do ki=1,lid
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        ch1(1,m2,ki,j) = cc1(1,m1,ki,j)-cc1(2,m1,ki,jc)
                        ch1(2,m2,ki,j) = cc1(2,m1,ki,j)+cc1(1,m1,ki,jc)
                        ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)+cc1(2,m1,ki,jc)
                        ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(1,m1,ki,jc)
                    end do
                end do
            end do
            do i=1,ido
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
                        cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
                    end do
                end do
            end do
            do j=2,iip
                do k=1,l1
                    m2 = m2s
                    do m1=1,m1d,im1
                        m2 = m2+im2
                        cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
                        cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
                    end do
                end do
            end do
            do j=2,iip
                do i=2,ido
                    do k=1,l1
                        m2 = m2s
                        do m1=1,m1d,im1
                            m2 = m2+im2
                            cc(1,m1,k,j,i) = wa(i,j-1,1)*ch(1,m2,k,i,j) &
                                +wa(i,j-1,2)*ch(2,m2,k,i,j)
                            cc(2,m1,k,j,i) = wa(i,j-1,1)*ch(2,m2,k,i,j) &
                                -wa(i,j-1,2)*ch(1,m2,k,i,j)
                        end do
                    end do
                end do
            end do
        end if

    end subroutine cmfgkf

end submodule multiple_complex_forward


      subroutine plcbas(h,p,c,d,ci,cs,ira,mi,md,x,f,w,iv,dlagr,imp,io,n,
     &                  modo,info,iter)
C     SUBROUTINE PLCBAS(H,P,C,D,CI,CS,IRA,MI,MD,X,F,W,IV,DLAGR,IMP,IO,N,
C    &                  MODO,INFO,ITER)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                             FECHA: Julio 2001                        *
C                             VERSION 2.1                              *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        La minimizacion  de un funcional cuadratico  con restricciones
C        lineales,  (de acotacion, igualdad  y  desigualdad), sobre las
C        variables.
C        El problema planteado es de la forma:
C
C               F(X)=  1/2*X'*H*X + P'*X
C
C              (1)  CI(I) <= X(I) <= CS(I), I=1,N
C              (2)  <(C(1,J),C(2,J),...,C(N,J)),X>  = D(J), J=1,MI
C              (3)  <(C(1,J),C(2,J),...,C(N,J)),X> <= D(J), J=MI+1,MI+MD
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        H      Matriz  de  dimension  (N,N), que contiene la matriz  H
C               del  termino  cuadratico  del  funcional.  Es suficiente
C               suministrar la parte triangular inferior.
C
C        P      Vector  N-dimensional.  Contiene  los  coeficientes  del
C               termino lineal del funcional.
C
C        C      Matriz de dimension (N,MI+MD). Contiene los coeficientes
C               de las restricciones  de igualdad y  desigualdad. Los de
C               igualdad se almacenan en las  MI primeras columnas de la
C               matriz  C  y los de desigualdad en las restantes.
C
C        D      Vector de dimension  MI+MD. Contiene los coeficientes de
C               los  terminos  independientes  de  las  restricciones de
C               igualdad y desigualdad.
C
C        CI     Si  IRA= 0  o  2  esta  variable  no sera  utilizada. Si
C               IRA= 1  o  3,   CI  sera  un  vector  de  dimension  N
C               conteniendo las cotas inferiores de  X. Si  X(I) no esta
C               acotado  inferiormente, CI(I)  debera ser  menor  que la
C               raiz cuadrada negativa  de la constante real  mas grande
C               de la maquina.
C
C        CS     Si  IRA= 0  o  1  esta  variable no  sera  utilizada. Si
C               IRA= 2  o  3,  CS   sera  un  vector  de  dimension  N
C               conteniendo las cotas superiores de  X. Si  X(I) no esta
C               acotado  superiormente,  CS(I)  debera  ser  mayor  que
C               la raiz cuadrada de la constante real  mas grande  de la
C               maquina.
C
C        IRA    Variable  que  indica  si  existen  restricciones  de
C               acotacion en el problema. Toma los valores:
C                  0  : No existen restricciones de acotacion.
C                  1  : Se  tienen  solo  restricciones  de  acotacion
C                       inferior.
C                  2  : Existen solo restricciones de acotacion superior
C                  3  : Se tienen ambos tipos de restriccion.
C
C        MI     Numero de restricciones de igualdad del problema.
C
C        MD     Numero  de  restricciones  de desigualdad  del  problema
C
C        W      Vector de trabajo de dimension  N*N+6*N+2*MD
C
C        IV     Vector entero  de dimension  3*N+2*MD+MI+1.
C
C        IMP    Indicador del nivel de impresion de salida de resultados
C               Toma los valores:
C                  6  : Sin salida de resultados.
C                  7  : Escribe el motivo de finalizacion del proceso.
C                  8  : Se obtiene informacion referente  a la solucion:
C                       el numero de iteraciones; el  optimo  calculado,
C                       la norma del vector de Kuhn-Tucker, el numero de
C                       restricciones activas y cuales   son    (para
C                       identificar estas restricciones  se  sigue el
C                       siguiente convenio para los valores que se
C                       obtienen:
C
C                       [-N,-1]         : Restriciones de cota inferior
C                       [ 1,N ]         : Restricciones de cota superior
C                       [N+1,N+MI]      : Restricciones de igualdad
C                       [N+MI+1,N+MI+MD]: Restricciones de desigualdad)
C
C                       y los multiplicadores de  Lagrange  asociados  a
C                       ellas  (si IND=0);  el valor  del funcional  ;
C                       la norma del punto calculado (si  IND=-3).
C
C                  9  : Se obtiene  informacion referente  al desarrollo
C                       de las iteraciones:  el numero de  restricciones
C                       activas   y cuales  son  (para identificarlas se
C                       sigue el convenio anterior), la restriccion que
C                       se a¤ade  o  se  elimina  del conjunto activo,
C                       el  tipo  de  direccion   de  descenso calculada
C                       y las iteraciones  con  punto degenerado.
C
C               > 10  : Ademas,  se  obtiene  el punto calculado en cada
C                       iteracion e informacion sobre el proceso llevado
C                       a cabo por OPTR01. (Ver valores posibles de  IMP
C                       en  OPTR01).
C
C        IO     Numero de canal de salida de resultados.
C
C        N      Numero de variables del problema.
C
C        MODO   Variable que indica el modo de comienzo del proceso con
C               los valores:
C                  1  : No se facilita un punto inicial,ni restricciones
C                       recomendadas como activas.
C                  2  : Igual que MODO = 1, pero la subrutina trabaja
C                       de forma diferente. Este caso debe utilizarse
C                       cuando hay valores de seguridad para las
C                       variables o las restricciones que son grandes y
C                       que previsiblemente no seran alcanzados.
C                       Tambien puede ser util este MODO cuando la
C                       forma cuadratica es definida positiva.
C                  3  : Se facilita un punto inicial. En este caso
C                       el punto ha de ser admisible para todas las
C                       restricciones.
C
C       ITER  : Numero maximo de iteraciones que realizara el proceso.
C               Si ITER <= 0, se cambiara por 14*(N+MI+MD)
C
C     DE SALIDA:
C
C        X      Vector de dimension  N que contiene el optimo calculado,
C               (si el proceso ha finalizado sin problemas), o la ultima
C               aproximacion obtenida.
C
C        F      Variable  que  contiene  el  valor  del funcional  en el
C               optimo si el proceso  ha finalizado sin problemas.
C
C      DLAGR    Vector de doble precision de dimension N+MI+MD si IRA es
C               mayor que cero y de dimension MI+MD si IRA=0.En las N
C               primeras componentes contiene los multiplicadores de
C               Lagrange asociados a las restricciones de cota (si IRA
C               es mayor que cero) y en las MI+MD ultimas componentes
C               contiene los multiplicadores asociados a las de igualdad
C               y desigualdad respectivamente.
C
C        INFO   Variable que indica el motivo por el cual se finaliza el
C               proceso. Toma el valor:
C                  1  : Se ha superado  el limite  de iteraciones fijado
C                       por el programa.
C                  0  : Se ha finalizado el proceso sin problemas.
C                 -1  : El funcional no esta acotado inferiormente.
C                 -2  : Se  encuentra  un punto  degenerado  con ciclaje
C                       indefinido.
C                 -3  : Posible problema no acotado.  La distancia entre
C                       los puntos  de dos iteraciones  consecutivas  es
C                       "demasiado grande".
C                 -4  : Los datos suministrados son incorrectos.
C                -11  : Incompatibilidad en el sistema de restricciones
C                       de igualdad en  OPTR01.
C                -12  : No existen puntos admisibles en  OPTR01 para las
C                       restricciones ajenas al funcional.
C                -13  : Se encuentra  un punto  degenerado  con  ciclaje
C                       indefinido en  OPTR01.
C                -14  : Se  ha  realizado  el limite  de iteraciones  en
C                       OPTR01 sin encontrar un punto admisible para las
C                       restricciones ajenas al funcional.
C
C        ITER   Numero de iteraciones que realiza el proceso.
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: anfm01,anfm02,anfm03,anfm04,anfm05,anfm06
C                anrs01,anrs02,auxo01,aux003,dadd,daxpy,dcopy,ddif,ddot,
C                desr03,dimp03,dipvtf,dmmul,dnrm0,dnrm2,dscal,dswap,
C                d1mach,idamax,nvtk03,optr01,optr03,opvf03,pasr03,
C                tol03,zthz
C     FUNCIONES FORTRAN INTRINSECAS: abs,max,min,mod,sign,sqrt
C
C
      implicit double precision(a-h,o-z)
      dimension h(n,*),p(*),c(n,*),d(*),ci(*),cs(*),x(*),w(*),iv(*),
     &          dlagr(*)
      iw=1
      alfa=1.d0
      mif=0
      mdf=0
      n1=n+1
      k=n1
      mid=mi+md
      nmd=n+md
      nmid=n+mid
      do 10 i=1,n
         k=k-1
         j=n*(i-1)+i
         call dcopy(k,h(i,i),1,w(j),1)
10    continue
      nipvt=1+nmd
      njpvt=nipvt+nmid+1
      nw=n*n1+1
      modo1=modo
      if(modo.eq.1) modo=6
      if(modo.eq.2) modo=1
      if(modo.eq.3) modo=2
      call optr03(w(1),1,c,n,h,n,w(1),n,p,b,d,ci,cs,x,w(nw),iw,iv,
     &            iv(nipvt),iv(njpvt),alfa,ira,n,m,mi,mi1,md,mif,
     &            mdf,modo,ind,imp,io,iter)
      modo=modo1
      info=ind
      k=n1
      do 20 i=1,n
         k=k-1
         j=n*(i-1)+i
         call dcopy(k,w(j),1,h(i,i),1)
 20   continue
      do 40 j=2,n
         do 30 i=1,j-1
 30      h(i,j)=h(j,i)
 40   continue
      if(ind.ne.0) return
      if(ind.eq.0) then
         f=w(nw+iw-1)
         nmul=nmd+nw
         if(ira.gt.0) then
            nl=n
         else
            nl=0
         end if
         do 12 i=1,nl+mid
12       dlagr(i)=0
         k=nipvt
         do 15 i=1,mi1
            j=iv(k)+nl
            dlagr(j)=w(nmul)
            nmul=nmul+1
            k=k+1
15       continue
         do 17 i=mi1+1,m
            j=iv(k)
            if(j.lt.0) then
               dlagr(-j)=-w(nmul)
            else if(j.le.n) then
               dlagr(j)=w(nmul)
            else
               if(ira.eq.0) j=j-n
               dlagr(j+mi)=w(nmul)
            end if
            nmul=nmul+1
            k=k+1
17       continue
      end if
      end


!*==zgeev.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGEEV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
!                         WORK, LWORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVL, JOBVR
!       INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   RWORK( * )
!       COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   W( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
!> eigenvalues and, optionally, the left and/or right eigenvectors.
!>
!> The right eigenvector v(j) of A satisfies
!>                  A * v(j) = lambda(j) * v(j)
!> where lambda(j) is its eigenvalue.
!> The left eigenvector u(j) of A satisfies
!>               u(j)**H * A = lambda(j) * u(j)**H
!> where u(j)**H denotes the conjugate transpose of u(j).
!>
!> The computed eigenvectors are normalized to have Euclidean norm
!> equal to 1 and largest component real.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N': left eigenvectors of A are not computed;
!>          = 'V': left eigenvectors of are computed.
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N': right eigenvectors of A are not computed;
!>          = 'V': right eigenvectors of A are computed.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A has been overwritten.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is COMPLEX*16 array, dimension (N)
!>          W contains the computed eigenvalues.
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is COMPLEX*16 array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!>          after another in the columns of VL, in the same order
!>          as their eigenvalues.
!>          If JOBVL = 'N', VL is not referenced.
!>          u(j) = VL(:,j), the j-th column of VL.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.  LDVL >= 1; if
!>          JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is COMPLEX*16 array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!>          after another in the columns of VR, in the same order
!>          as their eigenvalues.
!>          If JOBVR = 'N', VR is not referenced.
!>          v(j) = VR(:,j), the j-th column of VR.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1; if
!>          JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,2*N).
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, the QR algorithm failed to compute all the
!>                eigenvalues, and no eigenvectors have been computed;
!>                elements i+1:N of W contain eigenvalues which have
!>                converged.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!  @precisions fortran z -> c
!
!> \ingroup complex16GEeigen
!
!  =====================================================================
      SUBROUTINE ZGEEV(Jobvl,Jobvr,N,A,Lda,W,Vl,Ldvl,Vr,Ldvr,Work,Lwork,&
     &                 Rwork,Info)
      IMPLICIT NONE
!*--ZGEEV183
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvl , Jobvr
      INTEGER Info , Lda , Ldvl , Ldvr , Lwork , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Rwork(*)
      COMPLEX*16 A(Lda,*) , Vl(Ldvl,*) , Vr(Ldvr,*) , W(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , scalea , wantvl , wantvr
      CHARACTER side
      INTEGER hswork , i , ibal , ierr , ihi , ilo , irwork , itau ,    &
     &        iwrk , k , lwork_trevc , maxwrk , minwrk , nout
      DOUBLE PRECISION anrm , bignum , cscale , eps , scl , smlnum
      COMPLEX*16 tmp
!     ..
!     .. Local Arrays ..
      LOGICAL select(1)
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , XERBLA , ZDSCAL , ZGEBAK , ZGEBAL , ZGEHRD ,    &
     &         ZHSEQR , ZLACPY , ZLASCL , ZSCAL , ZTREVC3 , ZUNGHR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER IDAMAX , ILAENV
      DOUBLE PRECISION DLAMCH , DZNRM2 , ZLANGE
      EXTERNAL LSAME , IDAMAX , ILAENV , DLAMCH , DZNRM2 , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , DCMPLX , CONJG , AIMAG , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      wantvl = LSAME(Jobvl,'V')
      wantvr = LSAME(Jobvr,'V')
      IF ( (.NOT.wantvl) .AND. (.NOT.LSAME(Jobvl,'N')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantvr) .AND. (.NOT.LSAME(Jobvr,'N')) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldvl<1 .OR. (wantvl .AND. Ldvl<N) ) THEN
         Info = -8
      ELSEIF ( Ldvr<1 .OR. (wantvr .AND. Ldvr<N) ) THEN
         Info = -10
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace to real
!       workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by ZHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            maxwrk = 1
         ELSE
            maxwrk = N + N*ILAENV(1,'ZGEHRD',' ',N,1,N,0)
            minwrk = 2*N
            IF ( wantvl ) THEN
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'ZUNGHR',' ',N,1,N,-1))
               CALL ZTREVC3('L','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,Rwork,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,N+lwork_trevc)
               CALL ZHSEQR('S','V',N,1,N,A,Lda,W,Vl,Ldvl,Work,-1,Info)
            ELSEIF ( wantvr ) THEN
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'ZUNGHR',' ',N,1,N,-1))
               CALL ZTREVC3('R','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,Rwork,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,N+lwork_trevc)
               CALL ZHSEQR('S','V',N,1,N,A,Lda,W,Vr,Ldvr,Work,-1,Info)
            ELSE
               CALL ZHSEQR('E','N',N,1,N,A,Lda,W,Vr,Ldvr,Work,-1,Info)
            ENDIF
            hswork = INT(Work(1))
            maxwrk = MAX(maxwrk,hswork,minwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGEEV ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL ZLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Balance the matrix
!     (CWorkspace: none)
!     (RWorkspace: need N)
!
      ibal = 1
      CALL ZGEBAL('B',N,A,Lda,ilo,ihi,Rwork(ibal),ierr)
!
!     Reduce to upper Hessenberg form
!     (CWorkspace: need 2*N, prefer N+N*NB)
!     (RWorkspace: none)
!
      itau = 1
      iwrk = itau + N
      CALL ZGEHRD(N,ilo,ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvl ) THEN
!
!        Want left eigenvectors
!        Copy Householder vectors to VL
!
         side = 'L'
         CALL ZLACPY('L',N,N,A,Lda,Vl,Ldvl)
!
!        Generate unitary matrix in VL
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGHR(N,ilo,ihi,Vl,Ldvl,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VL
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL ZHSEQR('S','V',N,ilo,ihi,A,Lda,W,Vl,Ldvl,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
!
         IF ( wantvr ) THEN
!
!           Want left and right eigenvectors
!           Copy Schur vectors to VR
!
            side = 'B'
            CALL ZLACPY('F',N,N,Vl,Ldvl,Vr,Ldvr)
         ENDIF
!
      ELSEIF ( wantvr ) THEN
!
!        Want right eigenvectors
!        Copy Householder vectors to VR
!
         side = 'R'
         CALL ZLACPY('L',N,N,A,Lda,Vr,Ldvr)
!
!        Generate unitary matrix in VR
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGHR(N,ilo,ihi,Vr,Ldvr,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VR
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL ZHSEQR('S','V',N,ilo,ihi,A,Lda,W,Vr,Ldvr,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
!
      ELSE
!
!        Compute eigenvalues only
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL ZHSEQR('E','N',N,ilo,ihi,A,Lda,W,Vr,Ldvr,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
      ENDIF
!
!     If INFO .NE. 0 from ZHSEQR, then quit
!
      IF ( Info==0 ) THEN
!
         IF ( wantvl .OR. wantvr ) THEN
!
!        Compute left and/or right eigenvectors
!        (CWorkspace: need 2*N, prefer N + 2*N*NB)
!        (RWorkspace: need 2*N)
!
            irwork = ibal + N
            CALL ZTREVC3(side,'B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,nout,&
     &                   Work(iwrk),Lwork-iwrk+1,Rwork(irwork),N,ierr)
         ENDIF
!
         IF ( wantvl ) THEN
!
!        Undo balancing of left eigenvectors
!        (CWorkspace: none)
!        (RWorkspace: need N)
!
            CALL ZGEBAK('B','L',N,ilo,ihi,Rwork(ibal),N,Vl,Ldvl,ierr)
!
!        Normalize left eigenvectors and make largest component real
!
            DO i = 1 , N
               scl = ONE/DZNRM2(N,Vl(1,i),1)
               CALL ZDSCAL(N,scl,Vl(1,i),1)
               DO k = 1 , N
                  Rwork(irwork+k-1) = DBLE(Vl(k,i))**2 + AIMAG(Vl(k,i)) &
     &                                **2
               ENDDO
               k = IDAMAX(N,Rwork(irwork),1)
               tmp = CONJG(Vl(k,i))/SQRT(Rwork(irwork+k-1))
               CALL ZSCAL(N,tmp,Vl(1,i),1)
               Vl(k,i) = DCMPLX(DBLE(Vl(k,i)),ZERO)
            ENDDO
         ENDIF
!
         IF ( wantvr ) THEN
!
!        Undo balancing of right eigenvectors
!        (CWorkspace: none)
!        (RWorkspace: need N)
!
            CALL ZGEBAK('B','R',N,ilo,ihi,Rwork(ibal),N,Vr,Ldvr,ierr)
!
!        Normalize right eigenvectors and make largest component real
!
            DO i = 1 , N
               scl = ONE/DZNRM2(N,Vr(1,i),1)
               CALL ZDSCAL(N,scl,Vr(1,i),1)
               DO k = 1 , N
                  Rwork(irwork+k-1) = DBLE(Vr(k,i))**2 + AIMAG(Vr(k,i)) &
     &                                **2
               ENDDO
               k = IDAMAX(N,Rwork(irwork),1)
               tmp = CONJG(Vr(k,i))/SQRT(Rwork(irwork+k-1))
               CALL ZSCAL(N,tmp,Vr(1,i),1)
               Vr(k,i) = DCMPLX(DBLE(Vr(k,i)),ZERO)
            ENDDO
         ENDIF
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( scalea ) THEN
         CALL ZLASCL('G',0,0,cscale,anrm,N-Info,1,W(Info+1),            &
     &               MAX(N-Info,1),ierr)
         IF ( Info>0 ) CALL ZLASCL('G',0,0,cscale,anrm,ilo-1,1,W,N,ierr)
      ENDIF
!
      Work(1) = maxwrk
!
!     End of ZGEEV
!
      END SUBROUTINE ZGEEV


      program GinzLand

      USE Random_Numbers
      implicit none

      integer ndim
      parameter(ndim = 256)

      double precision phi(0:ndim+1,0:ndim+1)
      double precision phin(0:ndim+1,0:ndim+1)
      double precision func(0:ndim+1,0:ndim+1)
      double precision rnums(0:ndim+1,0:ndim+1)

      integer i,j,n,imax,jmax,nstep,ntherm,nfreq

      double precision dx,dy,dt, value, cfl, time, factor

      double precision alpha,gamma, k, a,b,c,d
      double precision phi_init, phi_0, integral
      double precision mean,std, ave, pi, x , y, rad
      double precision maxphi,minphi

      write(6,*)" imax,jmax,cfl,nstep,ntherm,nfreq"
      read(5,*) imax,jmax,cfl,nstep,ntherm,nfreq
      write(6,*) imax,jmax,cfl,nstep,ntherm,nfreq
      write(6,*)"gamma, alpha, k"
      read(5,*)gamma, alpha, k
      write(6,*)gamma, alpha, k
      write(6,*)"phi_init, phi_0"
      read(5,*)phi_init, phi_0
      write(6,*)phi_init, phi_0
      write(6,*)"a,b,c,d"
      read(5,*)a,b,c,d
      write(6,*)a,b,c,d
      read(5,*)rad

      call RandomSeeds(1905849284)

      dx = 1.d0/dfloat(imax)
      dy = 1.d0/dfloat(jmax)

      dt = 0.25d0*cfl*dx**2 / gamma

      factor = sqrt(2.d0*alpha/(dt*dx*dy))

      phi = phi_init

      pi= 4.d0*atan2(1.d0,1.d0)

      do j=1,jmax
      do i=1,jmax

         x = dx*dfloat(i-1)
         y = dy*dfloat(j-1)

      !  phi(i,j) =  (sin(2.d0*pi*x)*sin(2.d0*pi*y)) **2
         if( (x-.5d0)**2 + (y-.5d0)**2 .lt. rad**2)then
            phi(i,j) = 1.d0
         else
            phi(i,j) = 0.d0
         endif

      enddo
      enddo

      mean = 0.d0
      std = 0.d0

      do n=1,ntherm + nstep

         time = n*dt

         call periodic(phi,imax,jmax,ndim)
         call integrate(phi, phi_0, integral,dx,dy,imax,jmax,ndim)

         ave = 0.d0
         maxphi = phi(1,1)
         minphi = phi(1,1)

         do j=1,jmax
            do i=1,imax

             func(i,j) = a+2.d0*b*phi(i,j)+3.d0*c*phi(i,j)**2+4.d0*d*phi(i,j)**3
             call RandomNormal(value)
             rnums(i,j) = value

             mean = mean + value
             std = std + value**2
             ave= ave+phi(i,j)
             maxphi = max(maxphi, phi(i,j))
             minphi = min(minphi, phi(i,j))

           enddo
         enddo

         mean = mean / dfloat(imax*jmax)
         std = std / dfloat(imax*jmax)
         ave = ave / dfloat(imax*jmax)
         std = sqrt(std - mean**2)

         write(6,*)" average, max, min", ave,maxphi,minphi

         do j=1,jmax
           do i= 1,imax

             phin(i,j) = phi(i,j) + dt*gamma*(phi(i+1,j)-2.d0*phi(i,j)+phi(i-1,j))/dx**2  &
              + dt*gamma*(phi(i,j+1)-2.d0*phi(i,j)+phi(i,j-1))/dy**2  &
              -dt*func(i,j)-dt*k*integral + dt*factor * rnums(i,j)

           enddo
         enddo

       do j=1,jmax
       do i=1,imax

          phi(i,j) = phin(i,j)

      enddo
      enddo

      call output(1,imax,1,jmax,phi,time,ndim)

      if(n.gt.ntherm .and. mod(n,nfreq).eq.0)then

         write(8,*)"time=",time
         do j=1,jmax
         write(8,*) (phi(i,j),i=1,imax)
         enddo
      endif

      enddo

      end

      subroutine periodic(phi,imax,jmax,ndim)

          integer imax,jmax,ndim
          double precision phi(0:ndim+1,0:ndim+1)

        do j=1,jmax

           phi(0,j) = phi(imax,j)
           phi(imax+1,j) = phi(1,j)

        enddo

        do i=0,imax+1

           phi(i,0) = phi(i,jmax)
           phi(i,jmax+1) = phi(i,1)

        enddo

       return

       end subroutine periodic

      subroutine integrate(phi, phi_0, integral,dx,dy,imax,jmax,ndim)

          integer imax,jmax,ndim
          double precision phi(0:ndim+1,0:ndim+1)

          double precision phi_0, integral, dx, dy

          integral = 0.d0

          do j=1,jmax
          do i=1,imax

              integral = integral + phi(i,j) - phi_0

          enddo
          enddo

          integral = integral * dx * dy

      return
      end subroutine integrate