module mod_random
! module for pseudo random numbers
 implicit none
 private
 public init_random_seed, randint, r4_uniform
contains
 subroutine init_random_seed(seed)
  implicit none
  integer, intent(out) :: seed
  integer   day,hour,i4_huge,milli,minute,month,second,year
  parameter (i4_huge=2147483277)
  double precision temp
  character*(10) time
  character*(8) date
  call date_and_time (date,time)
  read (date,'(i4,i2,i2)')year,month,day
  read (time,'(i2,i2,i2,1x,i3)')hour,minute,second,milli
  temp=0.0D+00
  temp=temp+dble(month-1)/11.0D+00
  temp=temp+dble(day-1)/30.0D+00
  temp=temp+dble(hour)/23.0D+00
  temp=temp+dble(minute)/59.0D+00
  temp=temp+dble(second)/59.0D+00
  temp=temp+dble(milli)/999.0D+00
  temp=temp/6.0D+00
  doext: do
    if(temp<=0.0D+00 )then
       temp=temp+1.0D+00
       cycle doext
    else
       exit doext
    end if
  enddo doext
  doext2: do
    if (1.0D+00<temp) then
       temp=temp-1.0D+00
       cycle doext2
    else
       exit doext2
    end if
  end do doext2
  seed=int(dble(i4_huge)*temp)
  if(seed == 0)       seed = 1
  if(seed == i4_huge) seed = seed-1
  return
 end subroutine init_random_seed
 integer function randint(i,j,seed)
  real               ::  a,b
  integer,intent(in) ::  i,j,seed
  a = real(i)
  b = real(j)
  randint=int(r4_uniform(a,b+1.0,seed))
 end function randint
!
 real function r4_uniform(b1,b2,seed)
  implicit none
  real b1,b2
  integer i4_huge,k,seed
  parameter (i4_huge=2147483277)
  if(seed == 0) then
   write(*,'(b1)')'R4_UNIFORM - Fatal error!'
   write(*,'(b1)')'Input value of SEED = 0.'
   stop '[ERROR] Chiquitan chiquitintatan'
  end if
  k=seed/127773
  seed=16807*(seed-k*17773)-k*2836
  if(seed<0) then
    seed=seed+i4_huge
  endif
  r4_uniform=b1+(b2-b1)*real(dble(seed)* 4.656612875D-10)
  return
 end function r4_uniform
end module
! main program
program NMR
 use iso_fortran_env
 implicit none
 integer                         :: n_Ge = 0
 integer,parameter               :: n_resonator_max = 26
 integer                         :: i,j,k,ierr=0
 integer                         :: u = 100
 integer                         :: n_lines = 0
 integer,parameter               :: n_configurations_max = 1000
 integer                         :: virtual_n_configurations = 0
 integer,parameter               :: virtual_n_configurations_max = 1000
 integer,parameter               :: n_cells = 2*2*2
 integer,parameter               :: initialisation_steps = 10000000
 real                            :: virtual_n_Ge(n_cells,virtual_n_configurations_max)
 logical                         :: Quasi_Random_Virtual_Structures_flag = .false.
 logical                         :: forcefield = .false., inquite_Geometry_information_debug = .false.
 logical                         :: inquire_CIFFiles_flag = .false., inquite_Geometry_information=.false.
! arguments in line:
 integer                         :: num_args = 0
 character(len=100),dimension(:), allocatable :: args
! allocatables
 type                            :: virtual_extension
  real                           :: n_Ge
 end type
 type  :: microstate
  integer                        :: id = 0
  integer                        :: n_configurations = 0
  real                           :: peso(1:n_configurations_max) = 0.0
  real                           :: partition_function = 0.0
  character(len=1024)            :: CIFFile(1:n_configurations_max) = " "
  integer                        :: resonator(1:n_configurations_max,0:n_resonator_max-1) = 0
  real                           :: T_population(1:n_configurations_max,1:5) = 0
  real                           :: extended_virtual_n_Ge = 0.0
  real                           :: extended_virtual_n_Ge_sigma = 0.0
  integer                        :: extended_n_configurations = 0
  type(virtual_extension)        :: extended_ensemble(1:n_cells,virtual_n_configurations_max)
! cell properties:
  real                           :: cell_parameter(6,0:n_configurations_max)
  real                           :: volume(0:n_configurations_max)
  real                           :: rv_matrix(3,3,1:n_configurations_max)
  real                           :: vr_matrix(3,3,1:n_configurations_max)
  real                           :: distance_TO(0:2,0:n_configurations_max)
  real                           :: distance_TT(0:2,0:n_configurations_max)
  real                           :: angle_OTO(0:2,0:n_configurations_max)
  real                           :: angle_TOT(0:2,0:n_configurations_max)
 end type
 type(microstate)                :: ensemble(0:60)
 real                            :: count_(0:60,0:n_resonator_max-1+5) = 0.0
 real                            :: NMR_(0:60,0:n_resonator_max-1+5) = 0.0
 real                            :: NMR_unify(0:60,1:4) = 0.0
 real                            :: suma,x(1:16)
 real                            :: cell_0(6),vr(3,3),rv(3,3)
 integer                         :: cont,resonator
 real                            :: r4_average(0:60,1:8)=0.0
 character(len=1024)             :: filename = " "
 character(len=1024)             :: line = " "
 logical                         :: lex
 ! Read Arguments in line
 num_args=command_argument_count()
 allocate(args(num_args))
 do i = 1, num_args
  call get_command_argument(i,args(i))
 end do
 if(num_args >= 1)then
  do i=1,num_args
   select case(args(i))
    case('-h','--help')
     call print_help()
     stop
    case('-f','--forcefield')
     forcefield=.true.
    case('-e','--QSVS')
     Quasi_Random_Virtual_Structures_flag = .true.
    case('-g','--inquire-CIF')
     inquire_CIFFiles_flag = .true.
    case('-t','--inquire-topology')
     inquite_Geometry_information = .true.
    case('-x')
     inquite_Geometry_information_debug = .true.
   end select
  end do
 end if
! initialisation:
 ensemble(0)%n_configurations=1
 ensemble(0)%peso(1)=1.0
 ensemble(0)%CIFFile(1)='0_0.cif'
 ensemble(0)%resonator(1,0)=1
 ensemble(0)%T_population(1,1:5)=0
 ensemble(0)%extended_virtual_n_Ge=0.0
 ensemble(0)%extended_n_configurations = 1
 ensemble(0)%extended_ensemble(1:n_cells,1:1)%n_Ge = 0.0
 ensemble(0)%distance_TO(1,1)=1.620421
 ensemble(0)%distance_TO(2,1)=0.0
 ensemble(0)%distance_TT(1,1)=3.000330
 ensemble(0)%distance_TT(2,1)=0.0
 ensemble(0)%angle_OTO(1,1)=109.45
 ensemble(0)%angle_OTO(2,1)=0.0
 ensemble(0)%angle_TOT(1,1)=142.151852
 ensemble(0)%angle_TOT(2,1)=0.0
 ensemble(0)%T_population(1,1:5)=0.0
 !
 ensemble(60)%n_configurations=1
 ensemble(60)%peso(1)=1.0
 ensemble(60)%CIFFile(1)='60_0.cif'
 ensemble(60)%resonator(1,n_resonator_max-1)=1
 ensemble(60)%T_population(1,1:5)=1
 ensemble(60)%extended_virtual_n_Ge=60.0
 ensemble(60)%extended_n_configurations = 1
 ensemble(60)%extended_ensemble(1:n_cells,1:1)%n_Ge = 60.0
 ensemble(60)%distance_TO(1,0:)=1.722453
 ensemble(60)%distance_TO(2,0:)=1.724428
 ensemble(60)%distance_TT(1,0:)=3.214147
 ensemble(60)%distance_TT(2,0:)=3.214147
 ensemble(60)%angle_OTO(1,0:)=109.157674
 ensemble(60)%angle_OTO(2,0:)=109.157674
 ensemble(60)%angle_TOT(1,0:)=138.354665
 ensemble(60)%angle_TOT(2,0:)=138.354665
 ensemble(60)%T_population(1,1:5)=1.0
 !
 count_(0,0) = 6.0
 count_(60,n_resonator_max-1) = 6.0
 !
 if( inquire_CIFFiles_flag ) then
  ! 0
  call inquire_CIFFile( ensemble(0)%CIFFile(1), cell_0, rv, vr)
  ensemble(0)%cell_parameter(1:6,1) = cell_0(1:6)
  ensemble(0)%rv_matrix(1:3,1:3,1) = rv(1:3,1:3)
  ensemble(0)%vr_matrix(1:3,1:3,1) = vr(1:3,1:3)
  call cell(ensemble(0)%rv_matrix(1:3,1:3,1),ensemble(0)%vr_matrix(1:3,1:3,1),ensemble(0)%cell_parameter(1:6,1) )
  ensemble(0)%volume(1) = volume( ensemble(0)%rv_matrix(1:3,1:3,1)  )
  ! 60
  call inquire_CIFFile( ensemble(60)%CIFFile(1), cell_0, rv, vr)
  ensemble(60)%cell_parameter(1:6,1) = cell_0(1:6)
  ensemble(60)%rv_matrix(1:3,1:3,1) = rv(1:3,1:3)
  ensemble(60)%vr_matrix(1:3,1:3,1) = vr(1:3,1:3)
  call cell(ensemble(60)%rv_matrix(1:3,1:3,1),ensemble(60)%vr_matrix(1:3,1:3,1),ensemble(60)%cell_parameter(1:6,1) )
  ensemble(60)%volume(1) = volume( ensemble(60)%rv_matrix(1:3,1:3,1)  )
 end if
 !
 if( inquite_Geometry_information_debug ) then
  open(825,file="overall_input.txt",status='old',iostat=ierr)
  if(ierr/=0) stop
  open(826,file="germanium_input.txt",status='old',iostat=ierr)
  if(ierr/=0) stop
 end if
 ! ---------------------------------------------------------------------------------------------------------------------
 read_properties: do n_Ge=1,59
  n_lines=0
  open(u, file='inputs/analysis_'//trim(str(n_Ge))//'.txt',status='old',iostat=ierr)
  if(ierr/=0) then
   ensemble(n_Ge)%n_configurations=1
   ensemble(n_Ge)%id=n_Ge
   ensemble(n_Ge)%peso(1)=0
   ensemble(n_Ge)%resonator(1,0:n_resonator_max-1)=0
   ensemble(n_Ge)%T_population(1,1:5)=0
   ensemble(n_Ge)%CIFFile(1)=" "
   ensemble(n_Ge)%partition_function=0.0
   cycle read_properties
  end if
  if( inquite_Geometry_information ) then
   open(345, file='inputs/configuration_topology.'//trim(str(n_Ge))//'.txt',status='old',iostat=ierr)
   if(ierr/=0) stop "File not found."
  end if
  if ( inquite_Geometry_information_debug ) then
   read(825,*) j,ensemble(n_Ge)%distance_TO(1,0),ensemble(n_Ge)%angle_OTO(1,0),&
                 ensemble(n_Ge)%distance_TT(1,0),ensemble(n_Ge)%angle_TOT(1,0)
   read(826,*) j,ensemble(n_Ge)%distance_TO(2,0),ensemble(n_Ge)%angle_OTO(2,0),&
                 ensemble(n_Ge)%distance_TT(2,0),ensemble(n_Ge)%angle_TOT(2,0)
   do k=1,2
    do i=1,ensemble(n_Ge)%n_configurations
     ensemble(n_Ge)%distance_TO(k,i)=ensemble(n_Ge)%distance_TO(k,0)
     ensemble(n_Ge)%distance_TT(k,i)=ensemble(n_Ge)%distance_TT(k,0)
       ensemble(n_Ge)%angle_OTO(k,i)=  ensemble(n_Ge)%angle_OTO(k,0)
       ensemble(n_Ge)%angle_TOT(k,i)=  ensemble(n_Ge)%angle_TOT(k,0)
    end do
   end do
  end if
  inquire(u,EXIST=lex,name=filename)
  inquire_analysis: do
   read(u,'(a)',iostat=ierr) line
   if (ierr/=0) exit inquire_analysis
   n_lines=n_lines+1
  end do inquire_analysis
  rewind(u)
  ensemble(n_Ge)%n_configurations=n_lines-1
  ensemble(n_Ge)%id=n_Ge
  do i=1,ensemble(n_Ge)%n_configurations
   read(u,'(a)',iostat=ierr) line
   if (ierr/=0) exit
   read(line,*)ensemble(n_Ge)%peso(i),(ensemble(n_Ge)%resonator(i,j),j=0,n_resonator_max-1),&
    (ensemble(n_Ge)%T_population(i,j),j=1,5),ensemble(n_Ge)%CIFFile(i)
   if( inquire_CIFFiles_flag ) then
    vjw: do j=1,1024
     if(line(j:j)=="S") then
      cont=j
      exit vjw
     end if
    end do vjw
    pql: do j=cont,1024
     if(line(j:j)==" ")then
      resonator=j
      exit pql
     end if
    end do pql
    read(line(cont:resonator),'(a)') ensemble(n_Ge)%CIFFile(i)
    ensemble(n_Ge)%CIFFile(i)="inputs/"//ensemble(n_Ge)%CIFFile(i)
    ensemble(n_Ge)%CIFFile(i)=adjustl( trim( ensemble(n_Ge)%CIFFile(i) ) )
    call inquire_CIFFile( ensemble(n_Ge)%CIFFile(i), cell_0, rv, vr)
    ensemble(n_Ge)%cell_parameter(1:6,i) = cell_0(1:6)
    ensemble(n_Ge)%rv_matrix(1:3,1:3,i) = rv(1:3,1:3)
    ensemble(n_Ge)%vr_matrix(1:3,1:3,i) = vr(1:3,1:3)
    call cell(ensemble(n_Ge)%rv_matrix(1:3,1:3,i),ensemble(n_Ge)%vr_matrix(1:3,1:3,i),ensemble(n_Ge)%cell_parameter(1:6,i) )
    ensemble(n_Ge)%volume(i) = volume( ensemble(n_Ge)%rv_matrix(1:3,1:3,i)  )
    call Symmetrising(ensemble(n_Ge)%cell_parameter(1:6,i) ,ensemble(n_Ge)%rv_matrix(1:3,1:3,i),   &
         ensemble(n_Ge)%vr_matrix(1:3,1:3,i),   &
         ensemble(n_Ge)%volume(i) )
   end if
   if( inquite_Geometry_information ) then
     read(345,'(a)') line
     if(scan(line,"nan")==0)then
      read(line,*) ( ensemble(n_Ge)%distance_TO(j,i),j=1,2), ( ensemble(n_Ge)%distance_TT(j,i),j=1,2), &
                   (   ensemble(n_Ge)%angle_OTO(j,i),j=1,2), (   ensemble(n_Ge)%angle_TOT(j,i),j=1,2)
     else
      write(6,'(a,a)')'Found NaN: ',line
      ensemble(n_Ge)%peso(i)=0.0
      ensemble(n_Ge)%distance_TO(1:2,i)=0.0
      ensemble(n_Ge)%distance_TT(1:2,i)=0.0
      ensemble(n_Ge)%angle_OTO(1:2,i)=0.0
      ensemble(n_Ge)%angle_TOT(1:2,i)=0.0
     end if
   end if
  end do
  if(inquite_Geometry_information) close(345)
  ensemble(n_Ge)%partition_function=sum( ensemble(n_Ge)%peso( 1:ensemble(n_Ge)%n_configurations ) )
  do i=1,ensemble(n_Ge)%n_configurations
   do j=0,n_resonator_max-1+5
    !FORBIDEN RESONATORS
    if (j/=2.and.j/=6.and.j/=10.and.j/=16.and.j/=20) then
     if(forcefield)then
      if(ensemble(n_Ge)%partition_function/=0)then
       if(j<=n_resonator_max-1)then
        count_(n_Ge,j) = count_(n_Ge,j) + &
        ensemble(n_Ge)%resonator(i,j)*ensemble(n_Ge)%peso(i)/ensemble(n_Ge)%partition_function
       else
        count_(n_Ge,j) = count_(n_Ge,j) + &
        ensemble(n_Ge)%T_population(i,j-n_resonator_max+1)*ensemble(n_Ge)%peso(i)/ensemble(n_Ge)%partition_function
       end if
      end if
     else
      if(j<=n_resonator_max-1)then
       count_(n_Ge,j) = count_(n_Ge,j) + ensemble(n_Ge)%resonator(i,j)
      else
       count_(n_Ge,j) = count_(n_Ge,j) + ensemble(n_Ge)%T_population(i,j-n_resonator_max+1)
      end if
     end if
    end if
   end do
  end do
  write(6,'(a,1x,i4)')'N configurations:',ensemble(n_Ge)%n_configurations
  do i=1,ensemble(n_Ge)%n_configurations
   write(6,'(a,1x,a)')        'CIFFile:',ensemble(n_Ge)%CIFFile(i)(1:clen_trim(ensemble(n_Ge)%CIFFile(i)))
   if( inquire_CIFFiles_flag ) then
    write(6,'(a,1x,6(f14.7,1x))')    'Cell Parameters:',(ensemble(n_Ge)%cell_parameter(j,i),j=1,6)
    write(6,'(a,1x,f14.7)')    'Volume:',ensemble(n_Ge)%volume(i)
   end if
   if ( inquite_Geometry_information ) then
    write(6,*) (ensemble(n_Ge)%distance_TO(j,i),j=1,2)
    write(6,*) (ensemble(n_Ge)%distance_TT(j,i),j=1,2)
    write(6,*) (  ensemble(n_Ge)%angle_OTO(j,i),j=1,2)
    write(6,*) (  ensemble(n_Ge)%angle_TOT(j,i),j=1,2)
   end if
   if ( inquite_Geometry_information_debug ) then
    write(6,*) ensemble(n_Ge)%distance_TO(1,i),ensemble(n_Ge)%angle_OTO(1,i),&
               ensemble(n_Ge)%distance_TT(1,i),ensemble(n_Ge)%angle_TOT(1,i)
    write(6,*) ensemble(n_Ge)%distance_TO(2,i),ensemble(n_Ge)%angle_OTO(2,i),&
               ensemble(n_Ge)%distance_TT(2,i),ensemble(n_Ge)%angle_TOT(2,i)
   end if
   write(6,'(a,1x,f14.7)')    'Peso:',ensemble(n_Ge)%peso(i)
   write(6,'(a,1x,f14.7)')    'Partition Function:',ensemble(n_Ge)%partition_function
   write(6,'(a,1x,26(i2,1x))')'Resonadores:',( ensemble(n_Ge)%resonator(i,j),j=0,n_resonator_max-1 )
   write(6,'(a,1x,5(i2,1x),1x,a,1x,i2)') 'Populations:',(int(ensemble(n_Ge)%T_population(i,j)),j=1,5),&
    ':',int(sum(ensemble(n_Ge)%T_population(i,1:5)))
  end do
  write(6,*)'===='
  close(u)
 end do read_properties
 if( inquite_Geometry_information_debug) then
  close(825)
  close(826)
 end if
 write(6,'(a)')'Counts:'
 do n_Ge=0,60
  write(6,'(26(f5.2,1x))')(count_(n_Ge,j), j=0,n_resonator_max-1 + 5 )
 end do
 write(6,*)'===='
 write(6,'(26(i4,1x))')( sum(int(count_(0:60,j)) ), j=0,n_resonator_max-1 + 5 )
 write(6,*)'===='
 !
 if( Quasi_Random_Virtual_Structures_flag.and.n_cells>=2 ) write(6,'(a)')"Quasi Random Virtual Structures"
 do n_Ge=1,59
  if( Quasi_Random_Virtual_Structures_flag .eqv. .false. .or. n_cells == 1 ) then
   ensemble(n_Ge)%extended_n_configurations = 1
   ensemble(n_Ge)%extended_virtual_n_Ge = real(n_Ge)
   ensemble(n_Ge)%extended_ensemble(1:n_cells,1)%n_Ge = real(n_Ge)
  else
   call Quasi_Random_Virtual_Structures(n_cells,virtual_n_configurations_max,n_Ge,virtual_n_configurations,virtual_n_Ge)
   ensemble(n_Ge)%extended_n_configurations = virtual_n_configurations
   ensemble(n_Ge)%extended_virtual_n_Ge=0.0
   do i = 1, ensemble(n_Ge)%extended_n_configurations
    do k = 1,n_cells
     ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge = virtual_n_Ge(k,i)
     ensemble(n_Ge)%extended_virtual_n_Ge=ensemble(n_Ge)%extended_virtual_n_Ge+&
      ( ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge/real(n_cells*ensemble(n_Ge)%extended_n_configurations) )
    end do
   end do
  end if
  write(6,'(i3,1x,f14.7,1x,i5)')n_Ge,ensemble(n_Ge)%extended_virtual_n_Ge,ensemble(n_Ge)%extended_n_configurations
 end do
 ensemble(n_Ge)%T_population(1:n_configurations_max,1:5) = 0.0
 do n_Ge=0,60
  do resonator=0,n_resonator_max-1+5
   NMR_(n_Ge,resonator)=0.0
   if (resonator/=2.and.resonator/=6.and.resonator/=10.and.resonator/=16.and.resonator/=20) then
   do i=1,ensemble(n_Ge)%extended_n_configurations
    do k = 1,n_cells
     NMR_(n_Ge,resonator)=NMR_(n_Ge,resonator)+count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator)
     select case(resonator)
      case(0)
       NMR_unify(n_Ge,1)=NMR_unify(n_Ge,1)+count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator)
      case(1,4,5)
       NMR_unify(n_Ge,2)=NMR_unify(n_Ge,2)+count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator)
      case(3,7,15,19,23)
       NMR_unify(n_Ge,3)=NMR_unify(n_Ge,3)+count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator)
      case(11,18,24,25)
       NMR_unify(n_Ge,4)=NMR_unify(n_Ge,4)+count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator)
      case(n_resonator_max,n_resonator_max+1,n_resonator_max+2,n_resonator_max+3,n_resonator_max+4)
       ensemble(n_Ge)%T_population(1,resonator-n_resonator_max+1) = ensemble(n_Ge)%T_population(1,resonator-n_resonator_max+1) + &
        count_( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) ,resonator )
     end select
    end do
   end do
   end if
  end do
  suma=sum( NMR_(n_Ge,0:n_resonator_max-1))
  NMR_(n_Ge,0:n_resonator_max-1)=NMR_(n_Ge,0:n_resonator_max-1)/suma
  suma=sum(NMR_unify(n_Ge,1:4))
  NMR_unify(n_Ge,1:4)=NMR_unify(n_Ge,1:4)/suma
 end do
 open(u,file="populations.txt")
 do n_Ge=0,60
  suma=sum(ensemble(n_Ge)%T_population(1,1:5)/real(n_cells*ensemble(n_Ge)%extended_n_configurations))
  do j=1,5
   ensemble(n_Ge)%T_population(1,j)=ensemble(n_Ge)%T_population(1,j)*ensemble(n_Ge)%extended_virtual_n_Ge/ &
    real(suma*n_cells*ensemble(n_Ge)%extended_n_configurations)
  end do
  write(u,'(f14.7,1x,5(f14.7,1x))') ensemble(n_Ge)%extended_virtual_n_Ge,&
  ( ensemble(n_Ge)%T_population(1,j) ,j=1,5 )
 end do
 close(u)
 open(u,file="NMR.txt")
 do n_Ge=0,60
  write(u,'(f14.7,1x,27(f14.7,1x))') ensemble(n_Ge)%extended_virtual_n_Ge,&
   ( NMR_(n_Ge,resonator), resonator=0,n_resonator_max-1 ),sum( NMR_(n_Ge,0:n_resonator_max-1) )
 end do
 close(u)
 open(u,file="NMR_unify.txt")
 do n_Ge=0,60
  write(u,'(f14.7,1x,4(f14.7,1x))') ensemble(n_Ge)%extended_virtual_n_Ge,&
   ( NMR_unify(n_Ge,resonator), resonator=1,4 )
 end do
 close(u)
 !! cell averages
 do n_Ge=1,59
  do j=1,6
   call average(ensemble(n_Ge)%n_configurations,&
                ensemble(n_Ge)%cell_parameter(j,0:ensemble(n_Ge)%n_configurations),&
                ensemble(n_Ge)%peso )
  end do
  call average(ensemble(n_Ge)%n_configurations,ensemble(n_Ge)%volume,ensemble(n_Ge)%peso)
  do j=1,2
   call average( ensemble(n_Ge)%n_configurations,&
                 ensemble(n_Ge)%distance_TO(j,0:ensemble(n_Ge)%n_configurations),&
                 ensemble(n_Ge)%peso )
   call average( ensemble(n_Ge)%n_configurations,&
                 ensemble(n_Ge)%distance_TT(j,0:ensemble(n_Ge)%n_configurations),&
                 ensemble(n_Ge)%peso )
   call average( ensemble(n_Ge)%n_configurations,&
                 ensemble(n_Ge)%angle_OTO(j,0:ensemble(n_Ge)%n_configurations),&
                 ensemble(n_Ge)%peso )
   call average( ensemble(n_Ge)%n_configurations,&
                 ensemble(n_Ge)%angle_TOT(j,0:ensemble(n_Ge)%n_configurations),&
                 ensemble(n_Ge)%peso )
  end do
 end do
! 0
!_cell_length_a                       11.9021
!_cell_length_b                       11.9021
!_cell_length_c                       29.6920
! 60
!_cell_length_a                       12.663980
!_cell_length_b                       12.662056
!_cell_length_c                       30.972105
!ensemble(0)%cell_parameter(1,0:1)=11.9021
!ensemble(0)%cell_parameter(2,0:1)=11.9021
!ensemble(0)%cell_parameter(3,0:1)=29.6920
!ensemble(0)%cell_parameter(4,0:1)=90.0
!ensemble(0)%cell_parameter(5,0:1)=90.0
!ensemble(0)%cell_parameter(6,0:1)=120.0
!
!
!ensemble(60)%cell_parameter(1,0:1)=12.663
!ensemble(60)%cell_parameter(2,0:1)=12.663
!ensemble(60)%cell_parameter(3,0:1)=30.9721
!ensemble(60)%cell_parameter(4,0:1)=90.0
!ensemble(60)%cell_parameter(5,0:1)=90.0
!ensemble(60)%cell_parameter(6,0:1)=120.0
!
 if( inquire_CIFFiles_flag ) then
  ! 0
  call inquire_CIFFile( ensemble(0)%CIFFile(1), cell_0, rv, vr)
  ensemble(0)%cell_parameter(1:6,0) = cell_0(1:6)
  ensemble(0)%rv_matrix(1:3,1:3,1) = rv(1:3,1:3)
  ensemble(0)%vr_matrix(1:3,1:3,1) = vr(1:3,1:3)
  call cell(ensemble(0)%rv_matrix(1:3,1:3,1),ensemble(0)%vr_matrix(1:3,1:3,1),ensemble(0)%cell_parameter(1:6,0) )
  ensemble(0)%volume(0) = volume( ensemble(0)%rv_matrix(1:3,1:3,1)  )
  ! 60
  call inquire_CIFFile( ensemble(60)%CIFFile(1), cell_0, rv, vr)
  ensemble(60)%cell_parameter(1:6,0) = cell_0(1:6)
  ensemble(60)%rv_matrix(1:3,1:3,1) = rv(1:3,1:3)
  ensemble(60)%vr_matrix(1:3,1:3,1) = vr(1:3,1:3)
  call cell(ensemble(60)%rv_matrix(1:3,1:3,1),ensemble(60)%vr_matrix(1:3,1:3,1),ensemble(60)%cell_parameter(1:6,0) )
  ensemble(60)%volume(0) = volume( ensemble(60)%rv_matrix(1:3,1:3,1)  )
 end if

 ! QRVS averages:
 if( Quasi_Random_Virtual_Structures_flag.and.n_cells>=2 )then
  !ensemble(n_Ge)%distance_TO(,0)=ensemble(n_Ge)%distance_TO(j,0)
  ! properties: TO
  r4_average(0:60,1:8)=0.0
  do n_Ge = 0,60
   do j=1,8
    resonator=0
    suma=0.0
    do i=1,ensemble(n_Ge)%extended_n_configurations
     do k=1,n_cells
      resonator=resonator+1
      cont = int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge )
      if(cont==0)cont=1
      if(cont==60)cont=59
      kopwq: select case(j)
       case(1,2)
       suma=suma+ensemble(cont)%distance_TO(j  ,0)
       case(3,4)
       suma=suma+ensemble(cont)%distance_TT(j-2,0)
       case(5,6)
       suma=suma+  ensemble(cont)%angle_OTO(j-4,0)
       case(7,8)
       suma=suma+  ensemble(cont)%angle_TOT(j-6,0)
      end select kopwq
     end do
    end do
    r4_average(n_Ge,j)=suma/real(resonator)
   end do
  end do
  do n_Ge=0,60
   do j=1,8
    kosa: select case(j)
     case(1,2)
     ensemble(n_Ge)%distance_TO(j,0)=r4_average(n_Ge,j)
     case(3,4)
     ensemble(n_Ge)%distance_TT(j-2,0)=r4_average(n_Ge,j)
     case(5,6)
     ensemble(n_Ge)%angle_OTO(j-4,0)=r4_average(n_Ge,j)
     case(7,8)
     ensemble(n_Ge)%angle_TOT(j-6,0)=r4_average(n_Ge,j)
    end select kosa
   end do
  end do
  ! cell parameters
  r4_average(0:60,1:8)=0.0
  do n_Ge=0,60
   cps: do j=1,6
    resonator=0
    suma=0.0
    ik_extended: do i=1,ensemble(n_Ge)%extended_n_configurations
     do k = 1,n_cells
      resonator=resonator+1
      cont = int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge )
      suma=suma+ensemble(cont)%cell_parameter(j,0)
     end do
    end do ik_extended
    r4_average(n_Ge,j)=suma/real(resonator)
   end do cps
  end do
  do n_Ge=0,60
   do j=1,6
    ensemble(n_Ge)%cell_parameter(j,0)=r4_average(n_Ge,j)
   end do
  end do
  ! volume:
  do n_Ge=0,60
   suma = 0.0
   do i=1,ensemble(n_Ge)%extended_n_configurations
    do k = 1,n_cells
     suma=suma+ensemble( int(ensemble(n_Ge)%extended_ensemble(k,i)%n_Ge) )%volume(0)
    end do
   end do
   r4_average(n_Ge,1)=suma/real(n_cells*ensemble(n_Ge)%extended_n_configurations)
  end do
  do n_Ge=0,60
   ensemble(n_Ge)%volume(0)=r4_average(n_Ge,1)
  end do
 end if
 open(u,file="cell.txt")
 open(789,file="properties.txt")
 do n_Ge=0,60
  write(u,*)ensemble(n_Ge)%extended_virtual_n_Ge,( ensemble(n_Ge)%cell_parameter(j,0),j=1,6 ), ensemble(n_Ge)%volume(0)
  write(789,*)ensemble(n_Ge)%extended_virtual_n_Ge,(ensemble(n_Ge)%distance_TO(j,0),j=1,2),&
   (ensemble(n_Ge)%distance_TT(j,0),j=1,2),(ensemble(n_Ge)%angle_OTO(j,0),j=1,2),(ensemble(n_Ge)%angle_TOT(j,0),j=1,2)
 end do
 close(u)
 close(789)
 stop
 !
 contains
!
 subroutine average(n,data_,peso)
  implicit none
  integer,intent(in) :: n
  real,intent(inout) :: data_(0:n)
  real,intent(in)    :: peso(1:n)
  real               :: suma = 0.0,w(1:n)
  integer            :: i
  !
  !check: data
  w(1:n)=peso(1:n)
  suma=0.0
  do i=1,n
   if(ISNAN(data_(i)))then
    w(i)=0.0
   end if
   suma=suma+w(i)
  end do
  w(1:n)=w(1:n)/suma
  suma=0.0
  do i=1,n
   if(ISNAN(data_(i)).eqv..false.) suma=suma+data_(i)*w(i)
  end do
  data_(0)=suma
  return
 end subroutine average
!
 character(len=20) function str(k)
 !Convert an integer to string
    integer, intent(in) :: k
    write (str, *) k
    str = adjustl(str)
 end function str
 PURE INTEGER FUNCTION Clen(s)      ! returns same result as LEN unless:
 CHARACTER(*),INTENT(IN) :: s       ! last non-blank char is null
 INTEGER :: i
 Clen = LEN(s)
 i = LEN_TRIM(s)
 IF (s(i:i) == CHAR(0)) Clen = i-1  ! len of C string
 END FUNCTION Clen
 PURE INTEGER FUNCTION Clen_trim(s) ! returns same result as LEN_TRIM unless:
 CHARACTER(*),INTENT(IN) :: s       ! last char non-blank is null, if true:
 INTEGER :: i                       ! then len of C string is returned, note:
                                    ! Ctrim is only user of this function
 i = LEN_TRIM(s) ; Clen_trim = i
 IF (s(i:i) == CHAR(0)) Clen_trim = Clen(s)   ! len of C string
 END FUNCTION Clen_trim
!
 subroutine symmetrising(cell_0,rv,vr,vol)
  implicit none
  real,intent(inout) :: cell_0(1:6)
  real,intent(inout) :: rv(3,3),vr(3,3)
  real,intent(in)    :: vol
  cell_0(4)=90.0
  cell_0(5)=90.0
  cell_0(6)=120.0
  cell_0(1) = extract_a(cell_0,vol)
  cell_0(2) = cell_0(1)
  call cell(rv,vr,cell_0)
  return
 end subroutine symmetrising
!
 real function csc_deg(x)
  implicit none
  real :: x
  csc_deg = -(2*sin(x))/(cos(2*x)-1.0)
  return
 end function csc_deg
 real function cot_deg(x)
  implicit none
  real :: x
  cot_deg = -(sin(2*x))/(cos(2*x)-1.0)
  return
 end function cot_deg
 !
 real function extract_a(cell_0,v)
  implicit none
  real :: cell_0(6),v
  real :: pi,DEGTORAD
  real :: alp,bet,gam
  real :: cosa,cosb,cosg
  real :: sing
  pi = ACOS(-1.0)
  DEGTORAD=pi/180.0
  IF(cell_0(4) == 90.0) THEN
    cosa = 0.0
  ELSE
    ALP=cell_0(4)*degtorad
    COSA=cos(ALP)
  ENDIF
  IF(cell_0(5) == 90.0) THEN
    cosb = 0.0
  ELSE
    bet = cell_0(5)*degtorad
    cosb = cos(bet)
  ENDIF
  IF(cell_0(6) == 90.0) then
    sing = 1.0
    cosg = 0.0
  ELSE
    gam = cell_0(6)*degtorad
    sing = sin(gam)
    cosg = cos(gam)
  ENDIF
  extract_a = (sqrt(v)*sqrt(csc_deg(gam)))/( sqrt(cell_0(3))*( &
   1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
   2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0))
 ! Mathematica Solution:
 ! Sqrt[Csc[\[Gamma]]])/(Sqrt[
 !   c] (1 - Cos[\[Beta]]^2 - Cos[\[Beta]]^2 Cot[\[Gamma]]^2 +
 !     2 Cos[\[Alpha]] Cos[\[Beta]] Cot[\[Gamma]] Csc[\[Gamma]] -
 !     Cos[\[Alpha]]^2 Csc[\[Gamma]]^2)^(1/4))
 ! extract_a = (sqrt(v)*sqrt(csc_deg(gam))/ &
 !  ( cell_0(3))*(1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
 !  2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0)) )
 !extract_a= (V*csc_deg(gam))/(cell_0(2)*cell_0(3)*Sqrt( &
 !  1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
 !  2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0))
  return
 end function extract_a
!
 subroutine Quasi_Random_Virtual_Structures(n_cells,n_virtual_systems_max,n_average,n_virtual_systems,virtual_n_Ge)
  use mod_random
  implicit none
  integer,intent(in)  :: n_cells
  integer,intent(in)  :: n_average
  integer,intent(in)  :: n_virtual_systems_max
  integer,intent(out) :: n_virtual_systems
  real,intent(out)    :: virtual_n_Ge(n_cells,n_virtual_systems_max)
  real    :: a(8)
  integer :: i,j,k,l,n,seed
  integer :: n_T=60
  real    :: x_cell(1:n_cells),x_average,eta
  real    :: temperature=448.0     ! K
  real    :: k_B  = 8.61734E-5     ! eV/K
  real    :: beta, x, partition = 0.0
  real    :: probability_cell(n_cells),free(n_cells)
  real    :: e_1,e_2
  integer :: production_steps
  !
  n_virtual_systems = 0
  production_steps = n_virtual_systems_max
  !
  a(1) = -20.8423
  a(2) = -3.23967
  a(3) =  2.37499
  a(4) = -4.32484
  a(5) =  1.99623
  a(6) =  0.751645
  a(7) = -9.70216
  a(8) =  0.976337
  !
  virtual_n_Ge(1:n_cells,1:n_virtual_systems_max) = real(n_average)
  !
  call init_random_seed(seed)
  partition = 0.0
  beta = 1.0/(k_B*temperature)
  x_average=(n_average/real(n_T))
  do i=1,n_T
   x=(i/real(n_T))
  end do
  x_cell(1:n_cells) = x_average
   do l=1,n_cells
    e_1=Free_Energy(a,x_cell(l))
   end do
  call update_probability(a,beta,n_cells,x_cell,free,partition,probability_cell)
  search_configurations: do k=1,initialisation_steps+production_steps
   i=randint(1,n_cells,seed)
   j=randint(1,n_cells,seed)
   do while ( i==j )
    i=randint(1,n_cells,seed)
    j=randint(1,n_cells,seed)
   end do
   e_1=Free_Energy(a,x_cell(i)) + Free_Energy(a,x_cell(j))
   n=randint(1,3,seed)
   x_cell(i)=x_cell(i)+n/60.0
   x_cell(j)=x_cell(j)-n/60.0
   e_2=Free_Energy(a,x_cell(i)) + Free_Energy(a,x_cell(j))
   if ( e_1 >= e_2 ) then
    call update_probability(a,beta,n_cells,x_cell,free,partition,probability_cell)
     if(k>initialisation_steps.and.n_virtual_systems_max>n_virtual_systems)then
     n_virtual_systems=n_virtual_systems+1
     do i=1,n_cells
      virtual_n_Ge(i,n_virtual_systems)=n_T*x_cell( i )
     end do
     end if
   else
    eta=R4_UNIFORM(0.0,1.0,SEED)
     if ( eta < exp(-( e_2 - e_1 )/(k_B*temperature)) ) then
      call update_probability(a,beta,n_cells,x_cell,free,partition,probability_cell)
      if(k>initialisation_steps.and.n_virtual_systems_max>n_virtual_systems)then
      n_virtual_systems=n_virtual_systems+1
      do i=1,n_cells
       virtual_n_Ge(i,n_virtual_systems)=n_T*x_cell( i )
      end do
     end if
    else
    x_cell(i)=x_cell(i)-n/60.0
    x_cell(j)=x_cell(j)+n/60.0
    call update_probability(a,beta,n_cells,x_cell,free,partition,probability_cell)
    end if
   end if
   if (n_virtual_systems_max<=n_virtual_systems) exit search_configurations
  end do search_configurations
  return
 end subroutine Quasi_Random_Virtual_Structures
 subroutine update_probability(a,beta,n_cells,x_cell,free,partition,probability_cell)
 implicit none
  integer           :: j
  real,intent(in)   :: a(8),beta
  integer,intent(in):: n_cells
  real,intent(in)   :: x_cell(n_cells)
  real,intent(out)  :: probability_cell(n_cells)
  real,intent(out)  :: partition,free(n_cells)
  real :: free_min = 0.0
  partition=0.0
  do j=1,n_cells
   free(j)=Free_Energy(a,x_cell(j) )
  end do
  free_min=minval(free)
  do j =1,n_cells
   partition=partition + exp(-beta*(Free_Energy(a,x_cell(j) )-free_min ))
  end do
  do j=1,n_cells
   probability_cell(j)=exp(-beta*(Free_Energy(a,x_cell(j) ) - free_min))/partition
  end do
  return
 end subroutine
 real function Free_Energy(a,x)
  implicit none
  real, intent(in)   :: a(8)
  real, intent(in)   :: x
  real,parameter     :: muchisimo = 1e12
  if (x<0.or.x>1) then
   Free_Energy = muchisimo
  else
   if(forcefield)then
    Free_Energy = a(1)*(x-a(2))**2 + a(3)*(x-a(4))**3 + &
                a(5)*(x-a(6))**4 + a(7)*(x-a(8))**5
   else
    Free_Energy = 0.0
   end if
  end if
  return
 end function Free_Energy
 !
 subroutine inquire_CIFFile(CIFFilename,cell_0,rv,vr)
  implicit none
  character(len=1024),intent(in) :: CIFFilename
  character(len=80)              :: string_stop_head= "_atom_site_charge"
  integer                        :: uu = 120
  character(len=20)              :: spam
  real,intent(out)               :: cell_0(6)
  real,intent(out)               :: rv(3,3),vr(3,3)
  open(uu,file=CIFfilename,status='old',iostat=ierr)
  if(ierr/=0) then
   write(6,'(a,1x,a)')'[ERROR] opening CIF file', CIFfilename
   stop
  end if
  read_cif: do
   read(uu,'(a)',iostat=ierr) line
   if(ierr/=0) exit read_cif
   if(line(1:14)=="_cell_length_a")then
    read(line,*)spam,cell_0(1)
    cycle read_cif
   end if
   if(line(1:14)=="_cell_length_b")then
    read(line,*)spam,cell_0(2)
    cycle read_cif
   end if
   if(line(1:14)=="_cell_length_c")then
    read(line,*)spam,cell_0(3)
    cycle read_cif
   end if
   if(line(1:17)=="_cell_angle_alpha")then
    read(line,*)spam,cell_0(4)
    cycle read_cif
   end if
   if(line(1:16)=="_cell_angle_beta")then
    read(line,*)spam,cell_0(5)
    cycle read_cif
   end if
   if(line(1:17)=="_cell_angle_gamma")then
    read(line,*)spam,cell_0(6)
    cycle read_cif
   end if
   if(line(1:)==string_stop_head) exit read_cif
  end do read_cif
  call cell(rv,vr,cell_0)
  return
 end subroutine inquire_CIFFile
 !
 SUBROUTINE cell(rv,vr,cell_0)
  implicit none
  real, intent(in)  :: cell_0(6)
  real, intent(out) :: rv(3,3),vr(3,3)
  real, parameter   :: pi = ACOS(-1.0)
  real :: alp,bet
  real :: cosa,cosb,cosg
  real :: gam,sing
  real :: DEGTORAD
  DEGTORAD=pi/180.0
  IF(cell_0(4) == 90.0) THEN
    cosa = 0.0
  ELSE
    ALP=cell_0(4)*degtorad
    COSA=cos(ALP)
  ENDIF
  IF(cell_0(5) == 90.0) THEN
    cosb = 0.0
  ELSE
    bet = cell_0(5)*degtorad
    cosb = cos(bet)
  ENDIF
  IF(cell_0(6) == 90.0) then
    sing = 1.0
    cosg = 0.0
  ELSE
    gam = cell_0(6)*degtorad
    sing = sin(gam)
    cosg = cos(gam)
  ENDIF
  rv(1,1) = cell_0(1)
  rv(1,2) = cell_0(2)*cosg
  rv(1,3) = cell_0(3)*cosb
  rv(2,1) = 0.0
  rv(2,2) = cell_0(2)*sing
  rv(2,3) = cell_0(3)*(cosa - cosb*cosg)/sing
  rv(3,1) = 0.0
  rv(3,2) = 0.0
  rv(3,3) = sqrt( cell_0(3)*cell_0(3) - rv(1,3)*rv(1,3) - rv(2,3)*rv(2,3))
  call inverse(rv,vr,3)
  !WRITE(6,'(a)') 'Cell:'
  !WRITE(6,'(6F14.7)')( cell_0(j), j=1,6 )
  !WRITE(6,'(a)')'Linear Transformation Operator:'
  !DO i=1,3
  ! WRITE(6,'(F14.7,F14.7,F14.7)')( rv(i,j), j=1,3 )
  !ENDDO
  !WRITE(6,'(a)')'----------------------------------------'
  !WRITE(6,'(a)')'Inverse Linear Transformation Operator:'
  !DO i=1,3
  ! WRITE(6,'(F14.7,F14.7,F14.7)')( vr(i,j), j=1,3 )
  !ENDDO
  !WRITE(6,'(a)')'----------------------------------------'
 RETURN
 END SUBROUTINE cell
!
 SUBROUTINE uncell(rv,cell_0)
  implicit none
  real,intent(out)   :: cell_0(6)
  real,intent(in)    :: rv(3,3)
  integer            :: i,j
  real               :: temp(6)
  REAL               :: radtodeg
  REAL, PARAMETER    :: pi=ACOS(-1.0)
  radtodeg=180.0/PI
  do i = 1,3
    temp(i) = 0.0
    do j = 1,3
      temp(i) = temp(i) + rv(j,i)**2
    enddo
    temp(i) = sqrt(temp(i))
  enddo
  cell_0(1) = abs(temp(1))
  cell_0(2) = abs(temp(2))
  cell_0(3) = abs(temp(3))
  do i = 1,3
    temp(3+i) = 0.0
  enddo
  do j = 1,3
    temp(4) = temp(4) + rv(j,2)*rv(j,3)
    temp(5) = temp(5) + rv(j,1)*rv(j,3)
    temp(6) = temp(6) + rv(j,1)*rv(j,2)
  enddo
  temp(4) = temp(4)/(temp(2)*temp(3))
  temp(5) = temp(5)/(temp(1)*temp(3))
  temp(6) = temp(6)/(temp(1)*temp(2))
  cell_0(4) = radtodeg*acos(temp(4))
  cell_0(5) = radtodeg*acos(temp(5))
  cell_0(6) = radtodeg*acos(temp(6))
  DO i=4,6
     if (abs(cell_0(i) - 90.0 ).lt.0.00001) cell_0(i) = 90.0
     if (abs(cell_0(i) - 120.0).lt.0.00001) cell_0(i) = 120.0
  ENDDO
  RETURN
 END SUBROUTINE uncell
!
 SUBROUTINE inverse(a,c,n)
 implicit none
 integer n
 real a(n,n), c(n,n)
 real L(n,n), U(n,n), b(n), d(n), x(n)
 real coeff
 integer i, j, k
 L=0.0
 U=0.0
 b=0.0
 do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      end do
   end do
 end do
 do i=1,n
  L(i,i) = 1.0
 end do
 do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  end do
 end do
 do k=1,n
  b(k)=1.0
  d(1) = b(1)
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0
 end do
 RETURN
 END SUBROUTINE inverse
!
 real function volume(rv)
  implicit none
  real, intent(in)  :: rv(3,3)
  real       :: r1x
  real       :: r1y
  real       :: r1z
  real       :: r2x
  real       :: r2y
  real       :: r2z
  real       :: r3x
  real       :: r3y
  real       :: r3z
  real       :: vol
  r1x = rv(1,1)
  r1y = rv(2,1)
  r1z = rv(3,1)
  r2x = rv(1,2)
  r2y = rv(2,2)
  r2z = rv(3,2)
  r3x = rv(1,3)
  r3y = rv(2,3)
  r3z = rv(3,3)
  vol = r1x*(r2y*r3z - r2z*r3y) + r1y*(r3x*r2z - r3z*r2x) + r1z*(r2x*r3y - r2y*r3x)
  volume = abs(vol)
  RETURN
 end function
 !
 subroutine print_help()
    print '(a)', '  -h, --help, Print usage information and exit'
    print '(a)', '  -f, --forcefield, Use free energy for Average Calculations'
    print '(a)', '  -e, --QSVS, Quasi-Random-Virtual Structure'
    print '(a)', '  -g, --inquire-CIF'
    print '(a)', 'If you need a bigger system change n_cells or initialisation_steps'
 end subroutine print_help
end program NMR


      program indatatester
        use io
        use precision
        use physics
        use interpolation

        implicit none
        integer(lkind) Nruns, i
        real(rkind) e0, Pnull, Pcoll, cftot !ct, Pnull
        real(rkind), allocatable :: css(:)

        call read_program_input(Nruns, tfin, dt, e0, p)
        call init_interpolation()
        do i=1,NDataFiles
          call interpolate(i)
        end do
        call clean_up_io()
        call init_physics()

        allocate(css(NDataFiles))

        css = (/ (cross_section(e0, int(i,ikind)), i=1,NDataFiles) /)

        print *, "# Cross sections:"
        print *, css

        print *, "# Total/actual collision time:"
        cftot = velocity(e0)*n*sum(css)
        print *, 1/total_collision_frequency, 1/cftot

        print *, "# Probability of null collision:"
        Pnull = 1-cftot/total_collision_frequency
        write(*,'((F6.3),(A))') Pnull*100, "%"

        print *, "# Avg number of non-collided particles at tfin:"
        Pcoll = 1-(1-exp(-total_collision_frequency*tfin))*(1-Pnull)
        write(*,'((Es15.2),(F6.2),(A))') Pcoll*Nruns, 100*Pcoll, "%"

        call clean_up_interp()

        deallocate(css)
      end program indatatester


C    @(#)dpdx.f	20.3 2/13/96
      subroutine dpdx (kt,mt,y)
C
C     This subroutine computes the Jacobian elements dPij/dX
C     for branch KT-MT.
C

      include 'ipfinc/parametr.inc'

      include 'ipfinc/amtrx.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/ecvar.inc'

      real ikr,iki,imr,imi
      complex y(2,2)

      do 100 i = 1,ntotx-1
         dpt(1,i) = 0.0
         dpt(2,i) = 0.0
  100 continue

      ek = e(kt)
      fk = f(kt)
      em = e(mt)
      fm = f(mt)
      ikr = 0.0
      iki = 0.0

      g12 = real (y(1,2))
      b12 = aimag (y(1,2))
      imr=em*g12-fm*b12
      imi=em*b12+fm*g12
      ikr=ikr+imr
      iki=iki+imi
      rh=imr*fk-imi*ek
      rn=imr*ek+imi*fk
      mta = mt + ntota
      dpt(1,mta) = -rh
      dpt(2,mta) = -rn

      vksq = ek**2 + fk**2
      g12 = real (y(1,1)) * vksq
      b12 = aimag (y(1,1)) * vksq
      pk=ikr*ek+iki*fk+g12
      qk=ikr*fk-iki*ek-b12
      rh= -qk - b12
      rn = pk + g12
      kta = kt + ntota
      dpt(1,kta) = -rh
      dpt(2,kta) = -rn
      return
      end


C+
C
C  SUBROUTINE POLFT1
C
C  PURPOSE
C	MAKE A LEAST SQUARES FIT TO DATA WITH A POLYNOMIAL CURVE
C	Y = A(1) + A(2)*X + A(3)*X**2 + ...
C
C  USAGE
C	CALL POLFIT(X,Y,SIGMAY,NPTS,NTERMS,MODE,A,CHISQR,ARR,IER)
C
C  DESCRIPTION OF PARAMETERS
C	Y	- ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C	SIGMAY	- ARRAY OF STANDARD DEVIATIONS FOR Y-DATA POINTS
C		  (OR - IN CASE MODE = 4 - WEIGHTS FOR POINTS)
C	NPTS	- NO. OF PAIRS OF DATA POINTS
C	NTERMS	- NO. OF COEFFICIENTS (DEGREE OF POLYNOMIAL + 1)
C	MODE	- DETERMINES METHOD OF WEIGHTING LEAST SQUARES FIT
C		  4 (USER DEFINED) WEIGHT(I) = SIGMAY(I)
C		  3 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C		  2 (NO WEIGHTING) WEIGHT(I) = 1.
C		  1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C	A	- ARRAY OF COEFFICIENTS OF POLYNOMIAL
C	CHISQR	- REDUCED CHISQUARE FOR FIT
C	ARR	- DOUBLE PRECISION WORK BUFFER; MUST BE AT LEAST
C		  400 WORDS LONG IN THE CALLING ROUTINE
C	IER	- ERROR PARAMETER
C		  -1 DET=0
C		   0 O.K.
C		  +1 NOT ENOUGH POINTS
C
C  SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	DET(ARR,NORD) - EVALUATES THE DETERMINANT OF A SYMMETRIC
C			TWO DIMENSIONAL MATRIX OF ORDER NORD
C
C  COMMENTS
C	DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C	FOR DETAILS OF ALGORITHM SEE "DATA REDUCTION AND ERROR
C	ANALYSIS FOR THE PHYSICAL SCIENCES" - PH. R. BEVINGTON
C	MC GRAW-HILL BOOK COMPANY
C
C	IN THIS SPECIAL VERSION THE ELEMENTS OF COEFFICIENT MATRIX
C	ARR ARE NORMALIZED WITH RESPECT TO A VALUE COMPUTED VIA
C	LOGARITHMIC INTERPOLATION BETWEEN THE SMALLEST AND LARGEST
C	MATRIX ELEMENT
C
C  MODIFICATIONS BY A. SCHERMANN - INST. FOR ASTRONOMY,
C	UNIV. OF VIENNA, AUSTRIA
C
C Modified to assume x-variable is index of Y array
C-
	SUBROUTINE POLFT1(Y,SIGMAY,NPTS,NTERMS,MODE,A,CHISQR,ARR,IER)
	DOUBLE PRECISION SUMX(19),SUMY(10),ARR(10,10),XTERM,YTERM,
     1	CHISQ
	DIMENSION Y(1),SIGMAY(1),A(1)
	IER=0
C
C  CHECK DEGREE OF FREEDOM
	FREE=NPTS-NTERMS
	IF(FREE.GT.0.) GOTO 11
	IER=1
	GOTO 80
C
C  ACCUMULATE WEIGHTED SUMS
11	NMAX=2*NTERMS-1
	DO 13 N=1,NMAX
13	SUMX(N)=0.
	DO 15 J=1,NTERMS
15	SUMY(J)=0.
	CHISQ=0.
21	DO 50 I=1,NPTS
	XI=I
	YI=Y(I)
31	GOTO(32,37,38,39),MODE
32	IF(YI)35,37,33
33	WEIGHT=1./YI
	GOTO 41
35	WEIGHT=-1./YI
	GOTO 41
37	WEIGHT=1.
	GOTO 41
38	WEIGHT=1./SIGMAY(I)**2
	GOTO 41
39	WEIGHT=SIGMAY(I)
41	XTERM=WEIGHT
	DO 44 N=1,NMAX
	SUMX(N)=SUMX(N)+XTERM
44	XTERM=XTERM*XI
45	YTERM=WEIGHT*YI
	DO 48 N=1,NTERMS
	SUMY(N)=SUMY(N)+YTERM
48	YTERM=YTERM*XI
49	CHISQ=CHISQ+WEIGHT*YI**2
50	CONTINUE
C
C  GET LARGEST AND SMALLEST MATRIX ELEMENT (FOR NORMALIZATION)
	XTERM=SUMX(1)
	YTERM=XTERM
	DO 100 I=2,NMAX
	IF(SUMX(I).GT.XTERM) XTERM=SUMX(I)
	IF(SUMX(I).LT.YTERM) YTERM=SUMX(I)
100	CONTINUE
	DO 110 I=1,NTERMS
	IF(SUMY(I).GT.XTERM) XTERM=SUMY(I)
	IF(SUMY(I).LT.YTERM) YTERM=SUMY(I)
110	CONTINUE
	IF(YTERM.LE.0.) YTERM=1.D0
C
C  LOGARITHMIC INTERPOLATION OF NORMALIZATION VALUE
	XTERM=1.D1**((DLOG10(XTERM)+DLOG10(YTERM))/2.)
C
C  CONSTRUCT MATRICES AND CALCULATE COEFFICIENTS
51	DO 54 J=1,NTERMS
	DO 54 K=1,NTERMS
	N=J+K-1
54	ARR(J,K)=SUMX(N)/XTERM
	DELTA=DET(ARR,NTERMS)
	IF(DELTA.NE.0.) GOTO 61
57	CHISQR=0.
	DO 59 J=1,NTERMS
59	A(J)=0.
	IER=-1
	GOTO 80
61	DO 70 L=1,NTERMS
62	DO 66 J=1,NTERMS
	DO 65 K=1,NTERMS
	N=J+K-1
65	ARR(J,K)=SUMX(N)/XTERM
66	ARR(J,L)=SUMY(J)/XTERM
70	A(L)=DET(ARR,NTERMS)/DELTA
C
C  CALCULATE CHISQUARE
71	DO 75 J=1,NTERMS
	CHISQ=CHISQ-2.*A(J)*SUMY(J)
	DO 75 K=1,NTERMS
	N=J+K-1
75	CHISQ=CHISQ+A(J)*A(K)*SUMX(N)
77	CHISQR=CHISQ/FREE
80	RETURN
	END
c-----------------------------------------------------------
	FUNCTION POLYNO (COE,NPOL,IX)
C
C EVALUATE A POLYNOMIAL OF ORDER NPOL WITH COEFFICIENTS COE(1),...,
C COE (NPOL+1)  FOR AN INDEX IX
C
	DIMENSION COE(*)
C
	IF(NPOL.GT.0) GO TO 10
	POLYNO=COE(1)
	RETURN
C
10	POLYNO=COE(NPOL+1)
	DO 20 I=NPOL,1,-1
20	    POLYNO=POLYNO*IX+COE(I)
C
	RETURN
	END
c-----------------------------------------------------------
C+
C
C  FUNCTION DET
C
C  PURPOSE
C	CALCULATE DETERMINANT OF A SQUARE MATRIX
C
C  USAGE
C	DET = DET (ARR,NORDER)
C
C  DESCRIPTION OF PARAMETERS
C	ARRAY	- MATRIX
C	NORDER	- DEGREE OF MATRIX
C
C  SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C		NONE
C
C  COMMENTS
C	THIS SUBPROGRAM DESTROYS THE INPUT MATRIX ARRAY
C
	FUNCTION DET(ARRAY,NORDER)
	DOUBLE PRECISION ARRAY(10,10),SAVE
	DET=1.
	DO 90 K=1,NORDER
C  INTERCHANGE COLUMNS, IF DIAGONAL ELEMENT IS ZERO
	IF(ARRAY(K,K).NE.0.) GOTO 40
	DO 10 J=K,NORDER
	IF(ARRAY(K,J).NE.0.) GOTO 20
10	CONTINUE
	DET=0.
	GOTO 100
20	DO 30 I=K,NORDER
	SAVE=ARRAY(I,J)
	ARRAY(I,J)=ARRAY(I,K)
30	ARRAY(I,K)=SAVE
	DET=-DET
C  SUBTRACT ROW K FROM LOWER ROWS TO GET DIAGONAL MATRIX
40	DET=DET*ARRAY(K,K)
	IF(K-NORDER.GE.0) GOTO 90
	K1=K+1
	DO 50 I=K1,NORDER
	DO 50 J=K1,NORDER
50	ARRAY(I,J)=ARRAY(I,J)-ARRAY(I,K)*ARRAY(K,J)/ARRAY(K,K)
90	CONTINUE
100	RETURN
	END


subroutine addflux2pix(px,py,xmax,ymax,pixels,fmod)
!Jason Rowe 2015 - jasonfrowe@gmail.com
use precision
implicit none
integer xmax,ymax,npx,npy
real(double) :: fmod,dx,dy,px,py,pxmh,pymh,acheck
real(double), dimension(xmax,ymax) :: pixels

!so we add in flux with a 'psf' that is the size of one pixel

pxmh=px-0.5d0 !location of reference corner of PSF square
pymh=py-0.5d0

!acheck=0.0d0 !check that area is unity

!start with reference pixel
dx=floor(px+0.5)-pxmh !find edge of square
dy=floor(py+0.5)-pymh
npx=int(pxmh)
npy=int(pymh)
!check that pixel location is valid part of array
if((npx.gt.0).and.(npx.le.xmax).and.(npy.gt.0).and.(npy.le.ymax))then
   pixels(npx,npy)=pixels(npx,npy)+fmod*dx*dy
endif
!acheck=acheck+dx*dy

!+dx direction
npx=int(pxmh)+1
npy=int(pymh)
if((npx.gt.0).and.(npx.le.xmax).and.(npy.gt.0).and.(npy.le.ymax))then
   pixels(npx,npy)=pixels(npx,npy)+fmod*(1.0d0-dx)*dy
endif
!acheck=acheck+(1.0d0-dx)*dy

!+dy direction
npx=int(pxmh)
npy=int(pymh)+1
if((npx.gt.0).and.(npx.le.xmax).and.(npy.gt.0).and.(npy.le.ymax))then
   pixels(npx,npy)=pixels(npx,npy)+fmod*dx*(1.0d0-dy)
endif
!acheck=acheck+dx*(1.0d0-dy)

!+dx+dy direction
npx=int(pxmh)+1
npy=int(pymh)+1
if((npx.gt.0).and.(npx.le.xmax).and.(npy.gt.0).and.(npy.le.ymax))then
   pixels(npx,npy)=pixels(npx,npy)+fmod*(1.0d0-dx)*(1.0d0-dy)
endif
!acheck=acheck+(1.0d0-dx)*(1.0d0-dy)

!write(0,*) "area check: ",acheck

return
end


module model_velocity_div_curl
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE, TWO
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  A model for computing shear stress
    !!
    !!  Model Fields:
    !!      : shear_11, shear_12, shear_13
    !!      :           shear_22, shear_23
    !!      :                     shear_33
    !!
    !!  Lower-triangular components are not computed because the tensor is symmetric.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: velocity_div_curl_t

    contains

        procedure   :: init
        procedure   :: compute

    end type velocity_div_curl_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(velocity_div_curl_t), intent(inout)   :: self

        call self%set_name('Velocity Divergence and Curl')
        call self%set_dependency('f(Grad(Q))')

        call self%add_model_field('Velocity Divergence')
        call self%add_model_field('Velocity Curl - 1')
        call self%add_model_field('Velocity Curl - 2')
        call self%add_model_field('Velocity Curl - 3')
    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the Pressure and Temperature.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(velocity_div_curl_t),  intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), allocatable,    dimension(:) ::         &
            grad1_u,       grad2_u,       grad3_u,          &
            grad1_v,       grad2_v,       grad3_v,          &
            grad1_w,       grad2_w,       grad3_w,          &
            curl_vel_1, curl_vel_2, curl_vel_3,             &
            div_vel

        real(rk),   allocatable,    dimension(:) :: r

         grad1_u = worker%get_field('Velocity 1 - Gradient 1', 'value')
         grad2_u = worker%get_field('Velocity 1 - Gradient 2', 'value')
         grad3_u = worker%get_field('Velocity 1 - Gradient 3', 'value')

         grad1_v = worker%get_field('Velocity 2 - Gradient 1', 'value')
         grad2_v = worker%get_field('Velocity 2 - Gradient 2', 'value')
         grad3_v = worker%get_field('Velocity 2 - Gradient 3', 'value')

         grad1_w = worker%get_field('Velocity 3 - Gradient 1', 'value')
         grad2_w = worker%get_field('Velocity 3 - Gradient 2', 'value')
         grad3_w = worker%get_field('Velocity 3 - Gradient 3', 'value')

         div_vel = grad1_u + grad2_v + grad3_w

         curl_vel_1 = grad2_w-grad3_v
         curl_vel_2 = grad3_u-grad1_w
         curl_vel_3 = grad1_v-grad2_u

         call worker%store_model_field('Velocity Divergence', 'value', div_vel)

         call worker%store_model_field('Velocity Curl - 1', 'value', curl_vel_1)
         call worker%store_model_field('Velocity Curl - 2', 'value', curl_vel_2)
         call worker%store_model_field('Velocity Curl - 3', 'value', curl_vel_3)

    end subroutine compute
    !***************************************************************************************

end module model_velocity_div_curl


      recursive subroutine fpadpo(idim,t,n,c,nc,k,cp,np,cc,t1,t2)
      implicit none
c  given a idim-dimensional spline curve of degree k, in its b-spline
c  representation ( knots t(j),j=1,...,n , b-spline coefficients c(j),
c  j=1,...,nc) and given also a polynomial curve in its b-spline
c  representation ( coefficients cp(j), j=1,...,np), subroutine fpadpo
c  calculates the b-spline representation (coefficients c(j),j=1,...,nc)
c  of the sum of the two curves.
c
c  other subroutine required : fpinst
c
c  ..
c  ..scalar arguments..
      integer idim,k,n,nc,np
c  ..array arguments..
      real*8 t(n),c(nc),cp(np),cc(nc),t1(n),t2(n)
c  ..local scalars..
      integer i,ii,j,jj,k1,l,l1,n1,n2,nk1,nk2
c  ..
      k1 = k+1
      nk1 = n-k1
c  initialization
      j = 1
      l = 1
      do 20 jj=1,idim
        l1 = j
        do 10 ii=1,k1
          cc(l1) = cp(l)
          l1 = l1+1
          l = l+1
  10    continue
        j = j+n
        l = l+k1
  20  continue
      if(nk1.eq.k1) go to 70
      n1 = k1*2
      j = n
      l = n1
      do 30 i=1,k1
        t1(i) = t(i)
        t1(l) = t(j)
        l = l-1
        j = j-1
  30  continue
c  find the b-spline representation of the given polynomial curve
c  according to the given set of knots.
      nk2 = nk1-1
      do 60 l=k1,nk2
        l1 = l+1
        j = 1
        do 40 i=1,idim
          call fpinst(0,t1,n1,cc(j),k,t(l1),l,t2,n2,cc(j),n)
          j = j+n
  40    continue
        do 50 i=1,n2
          t1(i) = t2(i)
  50    continue
        n1 = n2
  60  continue
c  find the b-spline representation of the resulting curve.
  70  j = 1
      do 90 jj=1,idim
        l = j
        do 80 i=1,nk1
          c(l) = cc(l)+c(l)
          l = l+1
  80    continue
        j = j+n
  90  continue
      return
      end


CC=================================================================CC
CC                                                                 CC
CC  Subroutine CFFTSR(X,Y,M):                                      CC
CC      An in-place, split-radix complex FFT program               CC
CC      Decimation-in-frequency, cos/sin in second loop            CC
CC      and is computed recursively                                CC
CC      The program is based on Tran ASSP Feb 1986 pp152-156       CC
CC                                                                 CC
CC  Input/output                                                   CC
CC      X    Array of real part of input/output (length >= N)      CC
CC      Y    Array of imaginary part of input/output (length >= N) CC
CC      M    Transform length is N=2**M                            CC
CC                                                                 CC
CC  Calls:                                                         CC
CC      CSTAGE,CBITREV                                             CC
CC                                                                 CC
CC  Author:                                                        CC
CC      H.V. Sorensen,   University of Pennsylvania,  Dec. 1984    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC  Modified:                                                      CC
CC      H.V. Sorensen,   University of Pennsylvania,  Jul. 1987    CC
CC                                                                 CC
CC  Reference:                                                     CC
CC      Sorensen, Heideman, Burrus :"On computing the split-radix  CC
CC      FFT", IEEE Tran. ASSP, Vol. ASSP-34, No. 1, pp. 152-156    CC
CC      Feb. 1986                                                  CC
CC      Mitra&Kaiser: "Digital Signal Processing Handbook, Chap.   CC
CC      8, page 491-610, John Wiley&Sons, 1993                     CC
CC                                                                 CC
CC      This program may be used and distributed freely as         CC
CC      as long as this header is included                         CC
CC                                                                 CC
CC=================================================================CC
      SUBROUTINE CFFTSR(X,Y,M)
      REAL X(1), Y(1)
      N = 2**M
C-----L shaped butterflies------------------------------------------C
      N2 = 2*N
      DO  10 K = 1, M-1
          N2 = N2/2
          N4 = N2/4
          CALL CSTAGE(N,N2,N4,X(1),X(N4+1),X(2*N4+1),X(3*N4+1),
     $         Y(1),Y(N4+1),Y(2*N4+1),Y(3*N4+1))
 10   CONTINUE
C-----Length two butterflies----------------------------------------C
      IS = 1
      ID = 4
 20       DO  30 I1 = IS,N,ID
              T1      = X(I1)
              X(I1)   = T1 + X(I1+1)
              X(I1+1) = T1 - X(I1+1)
              T1      = Y(I1)
              Y(I1)   = T1 + Y(I1+1)
              Y(I1+1) = T1 - Y(I1+1)
 30       CONTINUE
          IS = 2*ID - 1
          ID = 4*ID
      IF (IS.LT.N) GOTO 20
C-------Digit reverse counter---------------------------------------C
      CALL CBITREV(X,Y,M)
      RETURN
      END
C===================================================================C
C  Subroutine CSTAGE - the work-horse of the CFFTSR                 C
C       Computes a stage of a complex split-radix length N          C
C       transform.                                                  C
C  Author                                                           C
C       H.V. Sorensen,   University of Pennsylvania,  Jul. 1987     C
C===================================================================C
      SUBROUTINE CSTAGE(N,N2,N4,X1,X2,X3,X4,Y1,Y2,Y3,Y4)
      REAL X1(1),X2(1),X3(1),X4(1),Y1(1),Y2(1),Y3(1),Y4(1)
      N8 = N4/2
C-------Zero butterfly----------------------------------------------C
      IS = 0
      ID = 2*N2
 10       DO  20  I1 = IS+1,N,ID
              T1     = X1(I1) - X3(I1)
              X1(I1) = X1(I1) + X3(I1)
              T2     = Y2(I1) - Y4(I1)
              Y2(I1) = Y2(I1) + Y4(I1)
              X3(I1) = T1     + T2
              T2     = T1     - T2
              T1     = X2(I1) - X4(I1)
              X2(I1) = X2(I1) + X4(I1)
              X4(I1) = T2
              T2     = Y1(I1) - Y3(I1)
              Y1(I1) = Y1(I1) + Y3(I1)
              Y3(I1) = T2     - T1
              Y4(I1) = T2     + T1
 20       CONTINUE
          IS = 2*ID - N2
          ID = 4*ID
      IF (IS .LT. N) GOTO 10
C
      IF  (N4-1) 100,100,30
C-------N/8 butterfly-----------------------------------------------C
 30   IS = 0
      ID = 2*N2
 40       DO  50 I1 = IS+1+N8,N,ID
              T1     = X1(I1) - X3(I1)
              X1(I1) = X1(I1) + X3(I1)
              T2     = X2(I1) - X4(I1)
              X2(I1) = X2(I1) + X4(I1)
              T3     = Y1(I1) - Y3(I1)
              Y1(I1) = Y1(I1) + Y3(I1)
              T4     = Y2(I1) - Y4(I1)
              Y2(I1) = Y2(I1) + Y4(I1)
              T5     = (T4 - T1)*0.707106778
              T1     = (T4 + T1)*0.707106778
              T4     = (T3 - T2)*0.707106778
              T2     = (T3 + T2)*0.707106778
              X3(I1) = T4 + T1
              Y3(I1) = T4 - T1
              X4(I1) = T5 + T2
              Y4(I1) = T5 - T2
 50       CONTINUE
          IS = 2*ID - N2
          ID = 4*ID
      IF (IS .LT. N-1) GOTO 40
C
      IF  (N8-1) 100,100,60
C-------General butterfly. Two at a time----------------------------C
 60   E  = 6.283185307179586/N2
      SS1 = SIN(E)
      SD1 = SS1
      SD3 = 3.*SD1-4.*SD1**3
      SS3 = SD3
      CC1 = COS(E)
      CD1 = CC1
      CD3 = 4.*CD1**3-3.*CD1
      CC3 = CD3
      DO  90  J = 2,N8
          IS = 0
          ID = 2*N2
          JN = N4 - 2*J + 2
 70           DO  80 I1=IS+J,N+J,ID
                  T1     = X1(I1) - X3(I1)
                  X1(I1) = X1(I1) + X3(I1)
                  T2     = X2(I1) - X4(I1)
                  X2(I1) = X2(I1) + X4(I1)
                  T3     = Y1(I1) - Y3(I1)
                  Y1(I1) = Y1(I1) + Y3(I1)
                  T4     = Y2(I1) - Y4(I1)
                  Y2(I1) = Y2(I1) + Y4(I1)
                  T5 = T1 - T4
                  T1 = T1 + T4
                  T4 = T2 - T3
                  T2 = T2 + T3
                  X3(I1) =  T1*CC1 - T4*SS1
                  Y3(I1) = -T4*CC1 - T1*SS1
                  X4(I1) =  T5*CC3 + T2*SS3
                  Y4(I1) =  T2*CC3 - T5*SS3
                  I2 = I1 + JN
                  T1     = X1(I2) - X3(I2)
                  X1(I2) = X1(I2) + X3(I2)
                  T2     = X2(I2) - X4(I2)
                  X2(I2) = X2(I2) + X4(I2)
                  T3     = Y1(I2) - Y3(I2)
                  Y1(I2) = Y1(I2) + Y3(I2)
                  T4     = Y2(I2) - Y4(I2)
                  Y2(I2) = Y2(I2) + Y4(I2)
                  T5 = T1 - T4
                  T1 = T1 + T4
                  T4 = T2 - T3
                  T2 = T2 + T3
                  X3(I2) =  T1*SS1 - T4*CC1
                  Y3(I2) = -T4*SS1 - T1*CC1
                  X4(I2) = -T5*SS3 - T2*CC3
                  Y4(I2) = -T2*SS3 + T5*CC3
 80           CONTINUE
              IS = 2*ID - N2
              ID = 4*ID
          IF (IS .LT. N) GOTO 70
C
          T1  = CC1*CD1 - SS1*SD1
          SS1 = CC1*SD1 + SS1*CD1
          CC1 = T1
          T3  = CC3*CD3 - SS3*SD3
          SS3 = CC3*SD3 + SS3*CD3
          CC3 = T3
 90   CONTINUE
 100  RETURN
      END
CC=================================================================CC
CC                                                                 CC
CC Subroutine CBITREV(X,Y,M):                                      CC
CC      Bitreverses the array X of length 2**M. It generates a     CC
CC      table ITAB (minimum length is SQRT(2**M) if M is even      CC
CC      or SQRT(2*2**M) if M is odd). ITAB need only be generated  CC
CC      once for a given transform length.                         CC
CC      The program uses the technique described by D. Evans       CC
CC      in Tran. ASSP Aug. 1987 pp1120-1125                        CC
CC                                                                 CC
CC Author:                                                         CC
CC      H.V. Sorensen,   University of Pennsylvania,  Aug. 1987    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC                                                                 CC
CC      This program may be used and distributed freely as long    CC
CC      as this header is included.                                CC
CC                                                                 CC
CC=================================================================CC
      SUBROUTINE CBITREV(X,Y,M)
      DIMENSION X(1),Y(1),ITAB(256)
C-------Initialization of ITAB array--------------------------------C
      M2 = M/2
      NBIT = 2**M2
      IF (2*M2.NE.M) M2 = M2 + 1
      ITAB(1) = 0
      ITAB(2) = 1
      IMAX = 1
      DO  10 LBSS = 2, M2
          IMAX = 2 * IMAX
          DO  10 I = 1, IMAX
              ITAB(I)      = 2 * ITAB(I)
              ITAB(I+IMAX) = 1 + ITAB(I)
 10   CONTINUE
C-----The actual bitreversal----------------------------------------C
      DO  20 K = 2, NBIT
          J0 = NBIT * ITAB(K) + 1
          I = K
          J = J0
          DO  20 L = 2, ITAB(K)+1
              T1   = X(I)
              X(I) = X(J)
              X(J) = T1
              T1   = Y(I)
              Y(I) = Y(J)
              Y(J) = T1
              I = I + NBIT
              J = J0 + ITAB(L)
 20   CONTINUE
      RETURN
      END


!*************************************************************************
!*************************************************************************
!        DRIVER for the  MODEL TO SIMULATE CROP GROWTH SUBJECTED TO
!           DAILY VARIATIONS OF WEATHER AND SOIL WATER CONDITIONS
!   Written in Microsoft FORTRAN for PC-compatible machines
!   Authors: RICARDO BRAGA and JADIR ROSA
!   Obs: This program is an assignment of the course AGE 5646-Agricultural
!      and Biological Systems Simulation.
!   Date: 03/31/1997
!   Modified 7/99 CHP - modified modular format, revised output format,
!         modified soil water routines, added water balance
!*************************************************************************

!     LIST OF VARIABLES

!     DOY    = Julian day
!     DOYP   = date of planting (Julian day)
!     endsim = code signifying physiological maturity (end of simulation)
!     FROP   = frequency of printout (days)
!     IPRINT = code for printout (=0 for printout)
!     LAI    = canopy leaf area index (m2 m-2)
!     PAR    = photosynthetically active radiation (MJ/m2/d)
!     RAIN   = daily rainfall (mm)
!     SRAD   = daily solar radiation (MJ/m2/d)
!     SWFAC1 = soil water deficit stress factor
!     SWFAC2 = soil water excess stress factor
!     TAIRHR = hourly average temperature (Celsius)
!     TMAX   = daily maximum temperature (Celsius)
!     TMIN   = daily minimum temperature (Celsius)

!**********************************************************************

PROGRAM MAIN

    !-----------------------------------------------------------------------
    use SoilCLI, only: sw
    use PlantCLI, only: plant
    use WeatherCLI, only: weathr
    IMPLICIT NONE

    REAL :: LAI, SWFAC1, SWFAC2
    REAL :: SRAD, TMAX, TMIN, PAR, RAIN
    INTEGER :: DOY, DOYP, endsim
    INTEGER :: FROP, IPRINT

    !************************************************************************
    !************************************************************************
    !     INITIALIZATION AND INPUT OF DATA
    !************************************************************************
    CALL OPENF(DOYP, FROP)

    CALL WEATHR(SRAD, TMAX, TMIN, RAIN, PAR, 'INITIAL   ')

    CALL SW(&
            DOY, LAI, RAIN, SRAD, TMAX, TMIN, & !Input
            SWFAC1, SWFAC2, & !Output
            'INITIAL   ')                                   !Control

    CALL PLANT(DOY, endsim, TMAX, TMIN, & !Input
            PAR, SWFAC1, SWFAC2, & !Input
            LAI, & !Output
            'INITIAL   ')                                   !Control

    !-----------------------------------------------------------------------
    !     DAILY TIME LOOP
    !-----------------------------------------------------------------------
    DO DOY = 0, 365
        IF (DOY /= 0) THEN

            CALL WEATHR(SRAD, TMAX, TMIN, RAIN, PAR, 'RATE      ')

            !************************************************************************
            !************************************************************************
            !     RATE CALCULATIONS
            !************************************************************************
            CALL SW(&
                    DOY, LAI, RAIN, SRAD, TMAX, TMIN, & !Input
                    SWFAC1, SWFAC2, & !Output
                    'RATE      ')                                 !Control

            IF (DOY > DOYP) THEN
                CALL PLANT(DOY, endsim, TMAX, TMIN, & !Input
                        PAR, SWFAC1, SWFAC2, & !Input
                        LAI, & !Output
                        'RATE      ')                               !Control
            ENDIF

            !************************************************************************
            !************************************************************************
            !     INTEGRATION OF STATE VARIABLES
            !************************************************************************
            CALL SW(&
                    DOY, LAI, RAIN, SRAD, TMAX, TMIN, & !Input
                    SWFAC1, SWFAC2, & !Output
                    'INTEG     ')                                 !Control

            IF (DOY > DOYP) THEN
                CALL PLANT(DOY, endsim, TMAX, TMIN, & !Input
                        PAR, SWFAC1, SWFAC2, & !Input
                        LAI, & !Output
                        'INTEG     ')                               !Control
            ENDIF

        ENDIF

        !************************************************************************
        !************************************************************************
        !     WRITE DAILY OUTPUT
        !************************************************************************

        IPRINT = MOD(DOY, FROP)
        IF ((IPRINT == 0) .OR. (endsim == 1) .OR. &
                (DOY == DOYP)) THEN

            CALL SW(&
                    DOY, LAI, RAIN, SRAD, TMAX, TMIN, & !Input
                    SWFAC1, SWFAC2, & !Output
                    'OUTPUT    ')                                 !Control

            IF (DOY >= DOYP) THEN
                CALL PLANT(DOY, endsim, TMAX, TMIN, & !Input
                        PAR, SWFAC1, SWFAC2, & !Input
                        LAI, & !Output
                        'OUTPUT    ')                               !Control
            ENDIF

        ENDIF

        IF (ENDSIM == 1) EXIT

        !-----------------------------------------------------------------------
        !     END OF DAILY TIME LOOP
        !-----------------------------------------------------------------------
    END DO

    !************************************************************************
    !************************************************************************
    !     CLOSE FILES AND WRITE SUMMARY REPORTS
    !************************************************************************
    CALL WEATHR(SRAD, TMAX, TMIN, RAIN, PAR, 'CLOSE     ')

    CALL SW(&
            DOY, LAI, RAIN, SRAD, TMAX, TMIN, & !Input
            SWFAC1, SWFAC2, & !Output
            'CLOSE     ')                                     !Control

    CALL PLANT(DOY, endsim, TMAX, TMIN, & !Input
            PAR, SWFAC1, SWFAC2, & !Input
            LAI, & !Output
            'CLOSE     ')
    !-----------------------------------------------------------------------
    STOP
END PROGRAM MAIN
!***************************************************************************

!***********************************************************************
!     SUBROUTINE OPENF(DOYP)
!     This subroutine opens the simulation control file, and reads date of
!     planting (DOYP)

!     SIMCTRL.INP => date of planting, frequency of printout
!***********************************************************************

SUBROUTINE OPENF(DOYP, FROP)

    IMPLICIT NONE
    INTEGER :: DOYP, FROP

    OPEN (UNIT = 8, FILE = 'data/simctrl.inp', STATUS = 'UNKNOWN')
    READ(8, 5) DOYP, FROP
    IF (FROP <= 0) FROP = 1
    5 FORMAT(2I6)
    CLOSE(8)

    !-----------------------------------------------------------------------
    RETURN
END SUBROUTINE OPENF
!***********************************************************************
!***********************************************************************


c*************************************************************************
c                          ANAL_ENERGY_WRITE_HJS.F
c*************************************************************************
c Writes the energy of the total system (massive bodies) wrt time in
c   the hierarchical Jacobi case
c
c      Input:
c            t             ==>  current time
c            nbod          ==>  number of massive bodies (int scalar)
c            mass          ==>  mass of bodies (real array)
c            umat          ==>  Conversion matrix Jacobi => Barycentric
c                                (2D real array)
c            xj,yj,zj      ==>  current position in Jacobi coord
c                               (real arrays)
c            vxj,vyj,vzj   ==>  current velocity in Jacobi coord
c                               (real arrays)
c            iu            ==>  unit to write to (int scalar)
c            fopenstat     ==>  The status flag for the open
c                                statements of the output files.
c                                          (character*80)
c            eoff          ==> An energy offset that is added to the energy
c                                      (real*8 scalar)
c
c Remarks: Adapted from anal_energy_write & anal_energy
c Authors:  Herve Beust
c Date:    Sep 4, 2006

      subroutine anal_energy_write_hjs(t,nbod,umat,mass,xj,yj,zj,
     &     vxj,vyj,vzj,iu,fopenstat,diro,eoff)

      include '../swift.inc'

c...  Inputs:
      integer nbod,iu
      real*8 mass(nbod),t,umat(NPLMAX,NPLMAX),eoff
      real*8 xj(nbod),yj(nbod),zj(nbod)
      real*8 vxj(nbod),vyj(nbod),vzj(nbod)
      character*80 fopenstat,diro

c...  Internals
      integer i1st
      real*8 energy,eltot(3),ke,pot
      real*8 elx,ely,elz
      real*8 xx,yy,zz,rr2
      real*8 xb(NPLMAX),yb(NPLMAX),zb(NPLMAX)
      real*8 vxb(NPLMAX),vyb(NPLMAX),vzb(NPLMAX)
      integer i,j
      data i1st/0/
      save i1st

c----
c...  Executable code

c Compute and print initial ke,pot,energy and ang. mom.

      call coord_g2b(nbod,umat,mass,xj,yj,zj,vxj,vyj,vzj,
     &      xb,yb,zb,vxb,vyb,vzb)

      eltot(1)=(yb(nbod)*vzb(nbod)-zb(nbod)*vyb(nbod))*mass(nbod)
      eltot(2)=(zb(nbod)*vxb(nbod)-xb(nbod)*vzb(nbod))*mass(nbod)
      eltot(3)=(xb(nbod)*vyb(nbod)-yb(nbod)*vxb(nbod))*mass(nbod)

      ke = 0.5*mass(nbod)*(vxb(nbod)**2 + vyb(nbod)**2 + vzb(nbod)**2)
      pot = 0.d0

      do i = 1,nbod-1

         elx=(yb(i)*vzb(i)-zb(i)*vyb(i))*mass(i)
         ely=(zb(i)*vxb(i)-xb(i)*vzb(i))*mass(i)
         elz=(xb(i)*vyb(i)-yb(i)*vxb(i))*mass(i)
         eltot(1) = eltot(1) + elx
         eltot(2) = eltot(2) + ely
         eltot(3) = eltot(3) + elz

         ke = ke + 0.5*mass(i)*(vxb(i)**2 + vyb(i)**2 + vzb(i)**2)
         do j = i+1,nbod

	    xx = xb(i) - xb(j)
	    yy = yb(i) - yb(j)
	    zz = zb(i) - zb(j)
	    rr2 = xx**2 + yy**2 + zz**2
	    pot = pot - mass(i)*mass(j)/(sqrt(rr2))

         enddo
      enddo

      energy = ke + pot + eoff

      call io_energy_write(i1st,t,energy,eltot,iu,diro,fopenstat)

      if(i1st.eq.0) then
         i1st=1
      endif

      return
      end     !anal_energy_write_hjs
c--------------------------------------------------------------------------


!*==ssyev.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSYEV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ, UPLO
!       INTEGER            INFO, LDA, LWORK, N
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), W( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SSYEV computes all eigenvalues and, optionally, eigenvectors of a
!> real symmetric matrix A.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA, N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the
!>          leading N-by-N upper triangular part of A contains the
!>          upper triangular part of the matrix A.  If UPLO = 'L',
!>          the leading N-by-N lower triangular part of A contains
!>          the lower triangular part of the matrix A.
!>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!>          orthonormal eigenvectors of the matrix A.
!>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!>          or the upper triangle (if UPLO='U') of A, including the
!>          diagonal, is destroyed.
!> \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 REAL array, dimension (N)
!>          If INFO = 0, the eigenvalues in ascending order.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL 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 length of the array WORK.  LWORK >= max(1,3*N-1).
!>          For optimal efficiency, LWORK >= (NB+2)*N,
!>          where NB is the blocksize for SSYTRD returned by ILAENV.
!>
!>          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] 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 algorithm failed to converge; i
!>                off-diagonal elements of an intermediate tridiagonal
!>                form did not converge to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realSYeigen
!
!  =====================================================================
      SUBROUTINE SSYEV(Jobz,Uplo,N,A,Lda,W,Work,Lwork,Info)
      IMPLICIT NONE
!*--SSYEV136
!
!  -- 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..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobz , Uplo
      INTEGER Info , Lda , Lwork , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , W(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      LOGICAL lower , lquery , wantz
      INTEGER iinfo , imax , inde , indtau , indwrk , iscale , llwork , &
     &        lwkopt , nb
      REAL anrm , bignum , eps , rmax , rmin , safmin , sigma , smlnum
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL SLAMCH , SLANSY
      EXTERNAL ILAENV , LSAME , SLAMCH , SLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL SLASCL , SORGTR , SSCAL , SSTEQR , SSTERF , SSYTRD ,     &
     &         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      wantz = LSAME(Jobz,'V')
      lower = LSAME(Uplo,'L')
      lquery = (Lwork==-1)
!
      Info = 0
      IF ( .NOT.(wantz .OR. LSAME(Jobz,'N')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(lower .OR. LSAME(Uplo,'U')) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ENDIF
!
      IF ( Info==0 ) THEN
         nb = ILAENV(1,'SSYTRD',Uplo,N,-1,-1,-1)
         lwkopt = MAX(1,(nb+2)*N)
         Work(1) = lwkopt
!
         IF ( Lwork<MAX(1,3*N-1) .AND. .NOT.lquery ) Info = -8
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSYEV ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
      IF ( N==1 ) THEN
         W(1) = A(1,1)
         Work(1) = 2
         IF ( wantz ) A(1,1) = ONE
         RETURN
      ENDIF
!
!     Get machine constants.
!
      safmin = SLAMCH('Safe minimum')
      eps = SLAMCH('Precision')
      smlnum = safmin/eps
      bignum = ONE/smlnum
      rmin = SQRT(smlnum)
      rmax = SQRT(bignum)
!
!     Scale matrix to allowable range, if necessary.
!
      anrm = SLANSY('M',Uplo,N,A,Lda,Work)
      iscale = 0
      IF ( anrm>ZERO .AND. anrm<rmin ) THEN
         iscale = 1
         sigma = rmin/anrm
      ELSEIF ( anrm>rmax ) THEN
         iscale = 1
         sigma = rmax/anrm
      ENDIF
      IF ( iscale==1 ) CALL SLASCL(Uplo,0,0,ONE,sigma,N,N,A,Lda,Info)
!
!     Call SSYTRD to reduce symmetric matrix to tridiagonal form.
!
      inde = 1
      indtau = inde + N
      indwrk = indtau + N
      llwork = Lwork - indwrk + 1
      CALL SSYTRD(Uplo,N,A,Lda,W,Work(inde),Work(indtau),Work(indwrk),  &
     &            llwork,iinfo)
!
!     For eigenvalues only, call SSTERF.  For eigenvectors, first call
!     SORGTR to generate the orthogonal matrix, then call SSTEQR.
!
      IF ( .NOT.wantz ) THEN
         CALL SSTERF(N,W,Work(inde),Info)
      ELSE
         CALL SORGTR(Uplo,N,A,Lda,Work(indtau),Work(indwrk),llwork,     &
     &               iinfo)
         CALL SSTEQR(Jobz,N,W,Work(inde),A,Lda,Work(indtau),Info)
      ENDIF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF ( iscale==1 ) THEN
         IF ( Info==0 ) THEN
            imax = N
         ELSE
            imax = Info - 1
         ENDIF
         CALL SSCAL(imax,ONE/sigma,W,1)
      ENDIF
!
!     Set WORK(1) to optimal workspace size.
!
      Work(1) = lwkopt
!
!
!     End of SSYEV
!
      END SUBROUTINE SSYEV


      subroutine roujalbe(k0,k1,k2,
     s           brdfalb)
      parameter (nta=24,nfa=48)
      real teta1,teta2,phi1,phi2,ta(nta),fa(nfa),wta(nta),wfa(nfa)
      real k0,k1,k2,brdfalb,psi,cpsi,mu1,mu2,si1,si2,ft
      real pi
      real summ,ts,tv,fr,pond,tts,ttv,xmus,xmuv,f2,f1
      integer k,j,l

      pi=atan(1.)*4.
      teta1=0.
      teta2=pi/2.
      call gauss(teta1,teta2,ta,wta,nta)
      phi1=0.
      phi2=2.*pi
      call gauss(phi1,phi2,fa,wfa,nfa)
      brdfalb=0.
      summ=0.
      do 1 k=1,nfa
      do 2 j=1,nta
      do 3 l=1,nta
      si2=sin(ta(j))
      si1=sin(ta(l))
      mu2=cos(ta(j))
      mu1=cos(ta(l))
      ts=ta(j)
      tv=ta(l)
      fr=acos(cos(fa(k)))
      pond=mu1*mu2*si1*si2*wfa(k)*wta(j)*wta(l)
      tts=tan(ts)
      ttv=tan(tv)
      xmus=cos(ts)
      xmuv=cos(tv)
      cpsi=xmus*xmuv+sin(ts)*sin(tv)*cos(fr)
      if (cpsi.lt.1.) then
      psi=acos(cpsi)
      else
      psi=0.
      endif
      f2=4./(3.*pi*(xmus+xmuv))*((pi/2-psi)*cpsi+sin(psi))-1./3.
      ft=tts*tts+ttv*ttv-2*tts*ttv*cos(fr)
      f1=0.5*((pi-fr)*cos(fr)+sin(fr))*tts*ttv-tts-ttv-sqrt(ft)
      f1=f1/pi
      brdfalb=brdfalb+(k0+k1*f1+k2*f2)*pond
      summ=summ+pond
  3   continue
  2   continue
  1   continue
      brdfalb=brdfalb/summ
      return
      end


module sym_cnst

  use precision, only: ip, sp, dp
  use test_vars, only: fmt_test_name, fmt_test_res

  use tridiag, only: tridiag_sym_cnst
  use tridiag_matmul, only: tridiag_matmul_sym_cnst

  implicit none

  real(sp) :: dev_sp
  real(dp) :: dev_dp

contains

  subroutine sym_cnst_tests()

    write(*, fmt_test_name, advance="no") "sym_cnst"

    dev_dp = sym_cnst_real_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_cnst_real_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    dev_dp = sym_cnst_cmplx_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_cnst_cmplx_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    write(*,*)

  end subroutine sym_cnst_tests

  real(dp) function sym_cnst_real_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_cnst_src/real.src"
  end function sym_cnst_real_dp

  real(dp) function sym_cnst_cmplx_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_cnst_src/cmplx.src"
  end function sym_cnst_cmplx_dp

  real(sp) function sym_cnst_real_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_cnst_src/real.src"
  end function sym_cnst_real_sp

  real(sp) function sym_cnst_cmplx_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_cnst_src/cmplx.src"
  end function sym_cnst_cmplx_sp

end module sym_cnst


program writeRegular
  real    :: x
  integer :: i
  integer :: ios

  open( UNIT=1,        FILE="testn.data", &
        ACTION="write", FORM="unformatted" )
  do i=1,10
    x=i*log10(real(i))
    write( unit=1, iostat=ios ) x
    if ( ios /= 0 ) exit
  end do
  close( unit=1 )
end program writeRegular


      subroutine mkcov(v,n1v,nrow,nv,s,c,n1c)
c-------------------------------------------------------------------
c        forms covariance matrix for a generalized inverse solution
c  derived from a truncated singular value decomposition.
c
c  arguments-
c    v   - nrow by nv array of right singular vectors from svd.
c          vectors are assumed to be in the rows of v.  only
c          nv vectors are used to form c.
c    n1v - first dimension of v in calling program
c    nrow- number of rows in v = number of columns in matrix
c          that svd was performed on.
c    nv  - number of singular vectors to keep.  this normally
c          would correspond to the number of singular values kept
c          in a generalized inverse generated by a trucated svd.
c    s   - vector of singular values
c    c   - (nrow by nrow) array to contain calculated covariance matrix
c    n1c - first dimension of c in calling program.
c
c  language - fortran
c  author   - gary l. pavlis
c  written  - may 1981
c-------------------------------------------------------------------
      integer n1v,nrow,nv,n1c
      real v(n1v,nv),s(nv),c(n1c,nrow)
c--loop control variables
      integer i,j
c--error exit for bad input
      if((nrow.lt.1).or.(nv.lt.1)) return
c--in the following the first row of c is used as a work space
c--c(1,1) is then treated separately in loop on label 250
c--only the upper triangle is calculated in the following do loops
c--lower triangle is produced by a copy operation (cputlt)
      do 200 j=2,nrow
            call scopy(nv,v(j,1),n1v,c,1)
            do 100 i=1,nv
                  c(i,1) = c(i,1)/s(i)**2
  100       continue
            do 150 i=1,j
                  c(i,j) = sdot(nv,c,1,v(i,1),n1v)
  150       continue
  200 continue
      c(1,1) = 0.0
      do 250 i=1,nv
            c(1,1) = c(1,1) + (v(1,i)/s(i))**2
  250 continue
      call cputlt(c,n1c,nrow)
      return
      end

c $Id$


module VarModule
  use ISO_FORTRAN_ENV
  implicit none
!	----------------------
!	Define KIND parameters
! ----------------------
  integer,     parameter :: IK = kind(1)
  integer(IK), parameter :: LK2 = kind(2)
  integer(IK), parameter :: LK8 = kind(8)
  integer(IK), parameter :: SP = kind(1.0)
  integer(IK), parameter :: DP = kind(1.0D0)
! ----------------------------
! Specify kinds used in Gamess
! ----------------------------
  integer(IK), parameter :: I8 = 8
  integer(IK), parameter :: IPgamess = 8  !4 = 32 bit integer, 8 = 64 bit integer
  integer(IK), parameter :: DPgamess = DP
  integer(IK), parameter :: LKgamess = 8
! -------------------------------
! Define length of default string
! -------------------------------
  integer(IK), parameter :: LCHARS = 60
!	---------------------------------------------
!	Set std unit numbers to system specified ones
!	---------------------------------------------
  integer(IK), parameter :: stdin  = INPUT_UNIT
  integer(IK), parameter :: stdout = OUTPUT_UNIT
  integer(IK), parameter :: stderr = ERROR_UNIT
!	---------
!	Constants
!	---------
  real(DP), parameter :: PI    = 3.1415926535897932384626433_DP
  real(DP), parameter :: TWOPI = PI+PI
  real(DP), parameter :: GOLD  = 1.6180339887498948482045868_DP
  real(DP), parameter :: CGOLD = 0.3819660112501051517954132_DP
! ------------------------------
! some common format definitions
! ------------------------------
 character(len=20), parameter :: plain   = '(a100)'
 character(len=20), parameter :: mofmt   = '(i6,es22.12)'
 character(len=20), parameter :: orbefmt = '(a4,f10.6)'
 character(len=20), parameter :: gmsvfmt = '(i2,i3,5(es15.8))'
! ------------------
! Define vector norm
! ------------------
  interface Norm2
    module procedure Norm2Real
    module procedure Norm2Complex
  end interface

  private Norm2Real, Norm2Complex

  interface matTrans
      module procedure subroutineMatrixTransform
  end interface

  private :: subroutineMatrixTransform

contains

  real(DP) function Norm2Real(vec)
    real(DP), intent(in) :: vec(:)
    Norm2Real = dot_product(vec,vec)
  end function
  real(DP) function Norm2Complex(vec)
    complex(DP), intent(in) :: vec(:)
    Norm2Complex = real(dot_product(vec,vec), kind=DP) !dot_product already takes conjugate
  end function

  function OuterProduct(vec1, vec2) result(matrix)
    real(DP), intent(in) :: vec1(:), vec2(:)
    real(DP)             :: matrix(size(vec1),size(vec2))
    matrix = spread(vec1, 2, size(vec2)) * spread(vec2, 1, size(vec1))
  end function

  elemental complex(DP) function ImExp(x)
    real(DP), intent(in) :: x

    ImExp = exp(cmplx(0.0_DP, x, kind=DP))
  end function

  elemental real(DP) function phase(re, im)
    real(DP), intent(in) :: re, im

    if (re > epsilon(1.0_DP)) then
      phase = atan(im/re)
    elseif (re < -epsilon(1.0_DP)) then
      if (im < 0.0_DP) then
        phase = atan(im/re) - PI
      else
        phase = atan(im/re) + PI
      endif
    else
      if (im > 0.0_DP) then
        phase =  0.5_DP*PI
      elseif (im < 0.0_DP) then
        phase = -0.5_DP*PI
      else
        phase =  0.0_DP
      endif
    endif
  end function

   function functionMatrixTransform(X,A,Y) result(R)
! R = X^T * A * Y
    real(dp), dimension(:,:), intent(in)  :: X,Y,A
    real(dp)                              :: R(size(A,1),size(A,2))
    real(dp), dimension(:,:), allocatable :: tmp

  allocate(tmp(size(A,1),size(A,2)))

  tmp = matmul(A,Y)
  R   = matmul(transpose(X),tmp)

  deallocate(tmp)
  end function FunctionMatrixTransform

  subroutine SubroutineMatrixTransform(X,A,Y)
! A = X^T * A * Y
    real(dp), dimension(:,:), intent(in)    :: X,Y
    real(dp), dimension(:,:), intent(inout) :: A
    real(dp), dimension(:,:), allocatable   :: tmp

  allocate(tmp(size(A,1),size(A,2)))

  tmp = matmul(A,Y)
  A   = matmul(transpose(X),tmp)

  deallocate(tmp)
  end subroutine SubroutineMatrixTransform

end module varModule


#include "scalar.fpp"
!=====================================================================!
! Module that implements an Aero-Elastic Oscillator reported in:
! Zhao, L. and Yang, Z., ``Chaotic motions of an airfoil with
! non-linear stiffness in incompressible flow,'' Journal of Sound and
! Vibration, Vol. 138, No. 2, 1990, pp. 245–254.
! =====================================================================!

module aero_elastic_oscillator_class

  use physics_class,  only : physics
  use function_class, only : abstract_function

  implicit none

  private

  public :: aero_elastic_oscillator

  !-------------------------------------------------------------------!
  ! Type that implements the aero-elastic oscillator (2 state vars)
  !-------------------------------------------------------------------!

  type, extends(physics) :: aero_elastic_oscillator

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: Q = 8.0d0  ! reduced dynamic pressure
     type(scalar) :: E = 20.0d0 ! non-linear stiffness factor

   contains

     procedure :: mapDesignVars
     procedure :: assembleResidual
     procedure :: assembleJacobian
     procedure :: getInitialStates
     procedure :: getResidualDVSens

  end type aero_elastic_oscillator

contains

  !-------------------------------------------------------------------!
  ! Residual assembly at each time step.
  ! u(1) is the plunging state of the oscillator
  ! u(2) is the pitching state of the oscillator
  ! -------------------------------------------------------------------!

  subroutine assembleResidual( this, res, time, u, udot, uddot )

    class(aero_elastic_oscillator) :: this
    type(scalar), intent(inout), dimension(:) :: res
    real(dp), intent(in) :: time
    type(scalar), intent(in), dimension(:) :: u, udot, uddot

    res(1) = uddot(1) + 0.25d0*uddot(2) + 0.1d0*udot(1) &
         & + 0.2d0*u(1) + 0.1d0*this % Q*u(2)

    res(2) = 0.25d0*uddot(1) + 0.5d0*uddot(2) + 0.1d0*udot(2) &
         & + 0.5d0*u(2) + this % E *u(2)*u(2)*u(2) - 0.1d0*this % Q*u(2)

  end subroutine assembleResidual

  !-------------------------------------------------------------------!
  ! Jacobian assembly at each time step. If you don't provide the
  ! analytical jacobian, set setApproximateJacobian(.true.) into the
  ! integrator object. We use finite-difference method to approximate
  ! the Jacobian.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differntiating a single equation. Each
  ! column in the Jacobian comes from a variable in the problem. Note
  ! the NEQN should be equal to NVARS for the system to be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDQdot and DRDQddot
  ! respectively.
  !-------------------------------------------------------------------!

  subroutine assembleJacobian( this, jac, alpha, beta, gamma, &
       & time, u, udot, uddot )

    class(aero_elastic_oscillator) :: this
    type(scalar), intent(inout), dimension(:,:) :: jac
    type(scalar), intent(in) :: alpha, beta, gamma
    real(dp), intent(in) :: time
    type(scalar), intent(in), dimension(:) :: u, udot, uddot

    ! Zero all entries first
    jac = 0.0d0

    !-----------------------------------------------------------------!
    ! Add dR/dQ
    !-----------------------------------------------------------------!

    ! derivative of first equation

    jac(1,1) = jac(1,1) + alpha*0.2d0
    jac(1,2) = jac(1,2) + alpha*0.1d0 * this % Q

    ! derivative of second equation

    jac(2,1) = jac(2,1) + alpha*0.0d0
    jac(2,2) = jac(2,2) + alpha*(0.5d0 + this % E*3.0d0*u(2)*u(2) - 0.1d0 * this % Q)

    !-----------------------------------------------------------------!
    ! Add dR/dQDOT
    !-----------------------------------------------------------------!

    ! derivative of first equation

    jac(1,1) = jac(1,1) + beta*0.1d0
    jac(1,2) = jac(1,2) + beta*0.0d0

    ! derivative of second equation

    jac(2,1) = jac(2,1) + beta*0.0d0
    jac(2,2) = jac(2,2) + beta*0.1d0

    !-----------------------------------------------------------------!
    ! Add dR/dQDDOT
    !-----------------------------------------------------------------!

    ! derivative of first equation

    jac(1,1) = jac(1,1) + gamma*1.0d0
    jac(1,2) = jac(1,2) + gamma*0.25d0

    ! derivative of second equation

    jac(2,1) = jac(2,1) + gamma*0.25d0
    jac(2,2) = jac(2,2) + gamma*0.50d0

  end subroutine assembleJacobian

  !---------------------------------------------------------------------!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and udot
  !---------------------------------------------------------------------!

  subroutine getInitialStates(this, time, u, udot)

    class(aero_elastic_oscillator) :: this

    real(dp), intent(in) :: time
    type(scalar), intent(inout), dimension(:) :: u, udot

    u(1) = 0.00d0
    u(2) = 0.00d0

    udot(1) = 0.01d0
    udot(2) = 0.00d0

  end subroutine getInitialStates

  !===================================================================!
  ! Return the number of state variables
  !===================================================================!

  function getNumStateVars(this)

    class(aero_elastic_oscillator) :: this
    integer          :: getNumStateVars

    getNumStateVars = this % num_state_vars

  end function getNumStateVars

  !-------------------------------------------------------------------!
  ! Routine for evaluating the gradient of Residual with respect
  ! to the design X
  !-------------------------------------------------------------------!

  subroutine getResidualDVSens(this, jac, scale, time, x, u, udot, uddot)

    class(aero_elastic_oscillator)         :: this
    type(scalar), intent(inout), dimension(:,:) :: jac
    real(dp), intent(in) :: time
    type(scalar), intent(in), dimension(:)      :: x, u, udot, uddot
    type(scalar)                                :: scale

    jac = 0.0d0

    jac(1,1) =   0.1d0*u(2)
    jac(1,2) =   0.0d0

    jac(2,1) = - 0.1d0*u(2)
    jac(2,2) =   u(2)*u(2)*u(2)

  end subroutine getResidualDVSens

  !-------------------------------------------------------------------!
  ! Map the the design variables into the class variables
  !-------------------------------------------------------------------!

  subroutine mapDesignVars(this)

    class(aero_elastic_oscillator) :: this

    this % Q = this % x(1)
    this % E = this % x(2)

  end subroutine mapDesignVars

end Module aero_elastic_oscillator_class


Cause various arithmetic errors to see what sort of hissy fit is thrown.
      REAL X2,X3,X4,Y4,XX,ZERO
      INTEGER IX4,IY4
      EQUIVALENCE (X4,IX4),(Y4,IY4)	!To view bits without provoking special fp handling.
      REAL*4 NaN4
      PARAMETER (NaN4 = Z'FFC00000')	!FFFFFFFF
c      PARAMETER (NaN4 = Z'FFFFFFFF')	!FFFFFFFF
      REAL*8 NaN8,X8(5),Y8,INF8
      PARAMETER (NaN8 = Z'FFF8000000000000')	!FFFFFFFF
c      PARAMETER (NaN8 = Z'FFFFFFFFFFFFFFFF')
      LOGICAL LX(5)
      INTEGER I
      X4 = NaN4
      WRITE (6,1) X4,IX4
    1 FORMAT ("X4 =",F12.4,' Hex ',Z8)
      WRITE (6,*) "Test X4 .EQ. Bad?  ",X4.EQ.NaN4
      WRITE (6,*) "Test X4 .NE. Bad?  ",X4.NE.NaN4
      WRITE (6,*) "Test IsNaN(X4)  ",ISNAN(X4)
      WRITE (6,*) "Test Abs(bad)   ",ABS(X4)
c      WRITE (6,*) "Test Exp(bad)",EXP(X4)
      Y8 = HUGE(Y8)
      WRITE(6,*) "Huge",Y8,LOG(Y8)
      Y8 = LOG(Y8)
      WRITE (6,*) "Hic",EXP(Y8)

      X2 = 0
      X3 = 0
      ZERO = 0
      XX = 666.66
      X2 = XX + X4
      WRITE (6,*) "Test x + BAD    ",X2
      WRITE (6,*) "Test 0/0        ",X3/ZERO
      WRITE (6,*) "Test 1/0        ",1/ZERO
      WRITE (6,*) "Test-1/0        ",-1/ZERO
      X2 = MIN(XX,X4)
      WRITE (6,*) "Test min(x,Bad) ",X2
      WRITE (6,*) "Test min(x,NaN4)",MIN(XX,NaN4)
c      WRITE (6,*) "Test mod(x,Bad) ",MOD(XX,X4)
c      WRITE (6,*) "Test mod(Bad,x) ",MOD(X4,XX)
c      WRITE (6,*) "Test mod(x,0)   ",MOD(XX,Z)
c      WRITE (6,*) "Sqrt(Bad)",SQRT(X4)

      DO I = 1,0,-1	!for sqrt(-1), a snarl.
        X4 = I
        X4 = X4/FLOAT(I)
        Y4 = SQRT(FLOAT(I))
        WRITE (6,10) I,I,X4,IX4,I,Y4,IY4
   10   FORMAT (I3,"/",I3," gives",F9.5," Hex ",Z8,
     1   ", Sqrt(",I3,") gives",F9.5," Hex ",Z8)
      END DO

Contemplate double precision.
      WRITE (6,*)
      WRITE (6,*) "Problems with IsNaN and arrays..."
      DO I = 1,5
        X8(I) = I
      END DO
      X8(3:4) = NaN8
      WRITE (6,*) "X=",X8
      WRITE (6,*) "X(2:4)=",X8(2:4)
      WRITE (6,*) "isnan(x(2:4))",ISNAN(X8(2:4))
      WRITE (6,*) "isnan(x(2))..(4))",ISNAN(X8(2)),ISNAN(X8(3)),
     1 ISNAN(X8(4))
      WRITE (6,*) "abs(x(2:4))",ABS(X8(2:4))
      WRITE (6,*) "isnan(abs(x(2:4)))",ISNAN(ABS(X8(2:4)))
      LX = ISNAN(X8)
      WRITE (6,*) "LX = isnan(X)",LX

      XX = HUGE(XX)
      WRITE(6,*) "Huge(x)=",XX,-XX
      XX = 1/ZERO
      WRITE(6,11) XX,-XX
   11 FORMAT("1/Zero=",Z8,", neg ",Z8)
      INF8 = XX
      WRITE (6,12) INF8,-INF8
   12 FORMAT("1/Zero=",Z16,", neg ",Z16)
      WRITE (6,*) "Burp!"
      END