!
!  Collection of subroutines for 3D nodal-DG velocity discretization of the Boltzmann collision integral
!  Will be integrated with CLAWPACK and with other codes
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      program main

      use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
      use readwrite ! contains useful subroutines for reading/writing. in particular the reading of the problem data file
      use miscset ! contains various setup subroutines, defines useful arrays, variables etc.
      use commvar, only: k_b,k_c,d_c,d_b,N,Mv,Mu,Mw,su,sv,sw,nodes_u,nodes_v,nodes_w,f,A_capphi,&
                  Mu_list,Mv_list,Mw_list,su_list,sv_list,sw_list,e_time,dt,t_L,t_R,num_save_solution,num_eval_error,rkmts,&
                  min_sens,Trad,fm,fmA,BfmA,run_mode,procs_nodes_wld,num_lin_proc,lin_proc_nodes_wld,lin_no_update,&
                  mpi_linear_coll_world,num_linstep_wait,fmA_flag,BfmA_flag,restart_time_txt,need_to_restart,&
                  g_max_order

      use dgvtools_mod
      use collision_mod
      use sf02, only:f_1D3D
      use time_integr_mod
      use distributions_mod
      use miscmpiset

      implicit none

      !!! MPI !!!
      include 'mpif.h' ! THIS IS TO ENABLE THE MPI ROUTINES
      !!! END MPI !!!

     ! Variables

 real (DP) :: test1 ! scrap variables
 real (DP), dimension(:), allocatable :: fcol,fcol_scr, Df ! scrap variable to keep results of the evaluation of collision operator
 integer (I4B) :: gg,loc_alloc_stat ! to keep them allocation status
 !!!!!!!!!!!
 real :: pr_time_1, pr_time_2 ! variable to calculate the processor time
 !!!!!!!!!!! SAVING SOLUTION AND SUCH !!!!!!!!!!!!!!!
 integer (I4B) :: rec, time_step, err_count
 real (DP) :: next_time_file_record, file_record_period, next_time_error_eval, error_eval_period
 character (len=15) :: suff  ! the string to hold the suffix
 real (DP)  :: ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w ! number density, av_v
 real (DP)  :: mom3_u,mom3_v,mom3_w,mom4_u,mom4_v,mom4_w,mom5_u,mom5_v,mom5_w,mom6_u,mom6_v,mom6_w ! higher moments
 real (DP), dimension (1:1000) :: time_a,ndens_a,ubar_a,vbar_a,wbar_a,tempr_a,tempr_u_a,tempr_v_a,tempr_w_a ! scrap arrays to keep the macroapameters in.
 real (DP), dimension (1:1000) :: mom3_u_a,mom3_v_a,mom3_w_a,mom4_u_a,mom4_v_a,mom4_w_a,mom5_u_a,mom5_v_a,mom5_w_a! scrap arrays to keep the macroapameters in.
 real (DP), dimension (1:1000) :: mom6_u_a,mom6_v_a,mom6_w_a ! scrap arrays to keep the macroapameters in.

 !!!!!!!!!!! MPI variables go below...
 integer :: ierr,irank ! variables for MPI Calls
 integer (I4B) :: nmsg ! long integer to store the length of the message
 !!!!!!!!!!!
      ! Body
 !!! MPI !!!
 !!! INITIALIZE THE MPI environment
 call mpi_init(ierr)
 !!! Now the MPI routines and variables will make sense ..
 !!! MPI FORK
 call mpi_comm_rank(MPI_COMM_WORLD,irank,ierr) ! check what processor the program is on...
 !!! Now we will check what processor we are on. The master processor
 if (irank == 0) then
     call SetUWbgkParams("parameters.dat",0) ! if the second variable is not zero than the subroutine returns printouts
 else
     call SetUWbgkParams("parameters.dat",1) ! if the second variable =0 then the printouts are not returend
 end if
 !!! END MPI FORK
      ! Read the problem parameters from the data file and set the problem variables.
      !call SetUWbgkParams("parameters.dat")
      ! set the order of used gauss-lobatto nodes in x and t
      k_b=7
      d_b=8
      d_c=2
      k_c=2

      call SetDGblzmGnodes ! sets some basic arrays of gauss and gauss-lobatto nodes.
      ! set the dimensions of the level zero meshes...
      N=3
      Mv=Mv_list(1)
      Mu=Mu_list(1)
      Mw=Mw_list(1)
      su=su_list(1)
      sv=sv_list(1)
      sw=sw_list(1)
      !! Consistency check: the the max allowed order of gauss quadrature is g_max_order
      !! if the user supplied values are bigger than that, the program will issue a warning and will stop.
      if (max(su,sv,sw)>g_max_order) then
       print *, "The supplied order of Gauss order exceeds allowed g_max_order (see in commonvar.f90). Stop"
       stop
      end if
      !! End consistency check:
      !
      call SetDGVblzmmesh  ! sets one-dimensional meshes in X and one-dimensional grids in u,v, and w
      call Set3DCellsR_DGVblzm
      !call CellsRefineDGV((/ 14 /),2,2,2)
      !call CellsRefineDGV((/ 27 + 14 /),3,3,3)
      call SetNodesDGV
      if (irank == 0) then
       call WriteCellsDGV
       call WriteGridsDGV
       call WriteNodesDGV
      end if
      !!! call WriteI1DGV(0.0_DP,0.0_DP,0.0_DP)
      !!! stop
      !!! MPI FORK !!!
      call PrepMPIcollsnDGV_highperf(irank)  ! distributed work and sets up some arrays that will be used in parallel evaluation of the collision integral
      !!! END MPI FORK !!!

     !!! Now all the preparations have been completed and the program is ready to compute the collision integral.
     !!! What will happen now is that the master node will broadcast the solution to the slave processors.
     !!! The slave processes will take this solution and compute a portion of the collision integral.
     !!! Then the master node will perform a collective operation to combine all peices into one.
     !!! THen the master node will perform the time step and update the solution. Aftert that the process is repeated
     !!! until the desired time is reaches.

     !!! To realize this algorithm we will make another fork. The master process will have the usual time integratio nroutines and all that.
     !!! the solution boradcast will be the fisrt operation then, the master node will call the collective operation in the evaluation
     !!! of the spatial part.

     !!! The slave process will run in the loop untill a signal is received that the time integration is complete.
     !!! the loop will consist of three operations: recived the updated f, compute the portion of the collision operator and sending
     !!! out the collision operator

     !!! Allocate arrays for the solution, for the local maxwllian and for the linearizaed operator.
     allocate (f(1:size(nodes_u,1)),fcol(1:size(nodes_u,1)),fm(1:size(nodes_u,1)),Df(1:size(nodes_u,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "DGVblzm: Allocation error for variables (f), (fcol), (fm)"
     end if
     !
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

     !!!!!!!!!!!!!!!!!!!!!!!
     !! INITIALIZE THE RUN_MODE to ZERO -- in the beginning the regime is strongly non-linear
     run_mode=0
     err_count=0
     lin_no_update=0 ! reset the counter for linear steps on the same derivative ...
     fmA_flag = 0; BfmA_flag = 0 ! reset the allocatable arrays status flag to "not-allocated"=0
     !!! MPI FORK !!!!
 if (irank == 0) then
     !!! Do this on the master processor
     !!!!!!!!!!!!!!!!!!!!! TIME EVOLUTION !!!!
     rkmts = 5
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! begin restart fork
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     if (need_to_restart) then
       call RestartSolutionDGV(restart_time_txt)
       Read (restart_time_txt, fmt = * ,  iostat = loc_alloc_stat) e_time ! set the current time to be equal to the time of restore
       err_count=0
     else
      rkmts = 5
      e_time = t_L ! initial time
      f = f_1D3D(0.0_DP, nodes_u, nodes_v, nodes_w, e_time) ! set up initial data
      !!!!!!!!!!!
      ! Write the initial data on disk.
      !!!!!!!!!!!
      suff = "i"
      call WriteSol_init_DGV (suff)
      ! compute the macroparameters of the initial data and save it on disk
      err_count=0
      !!!call MassCheckRecPlus (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w)
      call MassCheckRecHighCMoments (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w,mom3_u,mom3_v,mom3_w,mom4_u,mom4_v,&
                                       mom4_w,mom5_u,mom5_v,mom5_w,mom6_u,mom6_v,mom6_w)
      err_count=err_count+1
      if (err_count<1000) then
        time_a(err_count) = e_time
        ndens_a(err_count) = ndens
        ubar_a(err_count) = ubar
        vbar_a(err_count) = vbar
        wbar_a(err_count) = wbar
        tempr_a(err_count) = tempr
        tempr_u_a(err_count) = tempr_u
        tempr_v_a(err_count) = tempr_v
        tempr_w_a(err_count) = tempr_w
        mom3_u_a(err_count) = mom3_u
        mom3_v_a(err_count) = mom3_v
        mom3_w_a(err_count) = mom3_w
        mom4_u_a(err_count) = mom4_u
        mom4_v_a(err_count) = mom4_v
        mom4_w_a(err_count) = mom4_w
        mom5_u_a(err_count) = mom5_u
        mom5_v_a(err_count) = mom5_v
        mom5_w_a(err_count) = mom5_w
        mom6_u_a(err_count) = mom6_u
        mom6_v_a(err_count) = mom6_v
        mom6_w_a(err_count) = mom6_w
      else
        print *, "the number of error evaluations exceeded the storage, err_count >= 1000"
      end if
      !!!!!save macroparameters on hard drive
      !call WriteErrPlus_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
      !                        vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
      !                        tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count))
      call WriteErrHighCMoments_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
                              vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
                              tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count),&
                              mom3_u_a(1:err_count),mom3_v_a(1:err_count),mom3_w_a(1:err_count),mom4_u_a(1:err_count),&
                              mom4_v_a(1:err_count),mom4_w_a(1:err_count),mom5_u_a(1:err_count),mom5_v_a(1:err_count),&
                              mom5_w_a(1:err_count),mom6_u_a(1:err_count),mom6_v_a(1:err_count),mom6_w_a(1:err_count))
      !!!!! The initial data  and the initial macroparameters were saved on the hard drive    !!!!!
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      print *, "Got here...", pr_time_2 - pr_time_1 ! Report the account of time

      call cpu_time (pr_time_1) ! Start the account of time
      ! prepare MTS steps.
      time_step=0
      !!! AN MPI FORK IS HIDDEN HERE
      call PrepareMTS_SH_DGV (f, dt)
      !!! END OF THE MPI FORK
      call cpu_time (pr_time_2) ! End the account of time
      print *, "Processor time lapsed in seconds for Prepare MTS:", pr_time_2 - pr_time_1 ! Report the account of time
      !!!!!!
      !! TESTING MPI SPEEDUP
      !! comment the next 8 lines if not testing speedup.
      !!! broadcast an  end of work code to the processors...
      !!call mpi_bcast (-777,1,MPI_INTEGER4,0,MPI_COMM_WORLD,ierr)  ! -777  means end of work
      !!if (ierr /= 0 ) then
      !! print *,"CheckSolutionMode_MPI_DGV: MPI boradcast of run_mode from proc 0 returned error", ierr
      !!  stop
      !!end if
      !! call mpi_finalize(ierr)
      !! stop
      !!
      !! END Testing MPI SPEEDUP
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! now all the arrays are ready for the time evolution.
      ! save the solution at the initial stage:
      !write (suff, "(I4)") rec
      write (suff, "(F14.10)") e_time
      call WriteSol_DGV (suff)
      !!!!!evaluate macroparameters after the MTS prepare stage
      !call MassCheckRecPlus (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w)
      call MassCheckRecHighCMoments (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w,mom3_u,mom3_v,mom3_w,mom4_u,mom4_v,&
                                       mom4_w,mom5_u,mom5_v,mom5_w,mom6_u,mom6_v,mom6_w)
      err_count=err_count+1
      if (err_count<1000) then ! record the macroparameters
        time_a(err_count) = e_time
        ndens_a(err_count) = ndens
        ubar_a(err_count) = ubar
        vbar_a(err_count) = vbar
        wbar_a(err_count) = wbar
        tempr_a(err_count) = tempr
        tempr_u_a(err_count) = tempr_u
        tempr_v_a(err_count) = tempr_v
        tempr_w_a(err_count) = tempr_w
        mom3_u_a(err_count) = mom3_u
        mom3_v_a(err_count) = mom3_v
        mom3_w_a(err_count) = mom3_w
        mom4_u_a(err_count) = mom4_u
        mom4_v_a(err_count) = mom4_v
        mom4_w_a(err_count) = mom4_w
        mom5_u_a(err_count) = mom5_u
        mom5_v_a(err_count) = mom5_v
        mom5_w_a(err_count) = mom5_w
        mom6_u_a(err_count) = mom6_u
        mom6_v_a(err_count) = mom6_v
        mom6_w_a(err_count) = mom6_w
      else
        print *, "the number of error evaluations exceeded the storage, err_count >= 1000"
      end if
      !!!!!save macroparameters on hard drive
      !call WriteErrPlus_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
      !                        vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
      !                        tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count))
      call WriteErrHighCMoments_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
                              vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
                              tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count),&
                              mom3_u_a(1:err_count),mom3_v_a(1:err_count),mom3_w_a(1:err_count),mom4_u_a(1:err_count),&
                              mom4_v_a(1:err_count),mom4_w_a(1:err_count),mom5_u_a(1:err_count),mom5_v_a(1:err_count),&
                              mom5_w_a(1:err_count),mom6_u_a(1:err_count),mom6_v_a(1:err_count),mom6_w_a(1:err_count))
      !!!!! The MTS prepare stage data and the macroparameters were saved on the hard drive   !!!!!
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     end if
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! END OF RESTART FORK
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! measure time:
     call cpu_time (pr_time_1) ! Start the account of time
     ! set up error evaluation and solution recording
     file_record_period = (t_R-t_L)/Real(num_save_solution,DP)
     next_time_file_record = e_time + file_record_period
     error_eval_period = (t_R-t_L)/Real(num_eval_error,DP)
     next_time_error_eval = e_time + error_eval_period
     ! THE TIME LOOP
     do while (e_time <= t_R+0.00000000001_dp)
      time_step=time_step+1
      !!! AN MPI FORK IS HIDDEN HERE
      call TimeIntegratorMTS_SH_MPI_DGV(f,dt)
      !!! END OF AN MPI FORK
      ! check if it is time to evaluate error or any other quantity (like mass, bulk vel and tempr)
      if (e_time >= next_time_error_eval) then
       next_time_error_eval = e_time + error_eval_period
       ! evaluate mass momenum and tempretaure of the solution
       ! end eevaluate mass momenum and tempretaure of the solution
       !call MassCheckRecPlus (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w)
       call MassCheckRecHighCMoments (f,ndens,ubar,vbar,wbar,tempr,tempr_u,tempr_v,tempr_w,mom3_u,mom3_v,mom3_w,mom4_u,mom4_v,&
                                       mom4_w,mom5_u,mom5_v,mom5_w,mom6_u,mom6_v,mom6_w)
       err_count=err_count+1
       if (err_count<1000) then
        time_a(err_count) = e_time
        ndens_a(err_count) = ndens
        ubar_a(err_count) = ubar
        vbar_a(err_count) = vbar
        wbar_a(err_count) = wbar
        tempr_a(err_count) = tempr
        tempr_u_a(err_count) = tempr_u
        tempr_v_a(err_count) = tempr_v
        tempr_w_a(err_count) = tempr_w
        mom3_u_a(err_count) = mom3_u
        mom3_v_a(err_count) = mom3_v
        mom3_w_a(err_count) = mom3_w
        mom4_u_a(err_count) = mom4_u
        mom4_v_a(err_count) = mom4_v
        mom4_w_a(err_count) = mom4_w
        mom5_u_a(err_count) = mom5_u
        mom5_v_a(err_count) = mom5_v
        mom5_w_a(err_count) = mom5_w
        mom6_u_a(err_count) = mom6_u
        mom6_v_a(err_count) = mom6_v
        mom6_w_a(err_count) = mom6_w
       else
        print *, "the number of error evaluations exceeded the storage, err_count >= 1000"
       end if
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       ! DIAGNOSTIC call to record a derivatives of macroparameters and the relaxation times of macroparameters.
       ! The function will use the updated frhs1 directly from commvar and the old f can be found in f1 directly from commvar;
       ! The time corresponds to the time step of f1.
       !!!!
       call RecordMomDerivRelaxTimes_DGV(e_time-dt)
       !!!!
       ! END DIAGNOSTIC
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      end if
      ! Check if it is time to save the solution
      if (e_time >= next_time_file_record) then
        next_time_file_record = next_time_file_record + file_record_period
      ! write the solution of disk
       !rec=rec+1
       !write (suff, "(I4)") rec
       write (suff, "(F14.10)") e_time
       call WriteSol_DGV (suff)
       !call WriteErrPlus_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
       !                       vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
       !                       tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count))
       call WriteErrHighCMoments_DGV (time_a(1:err_count),ndens_a(1:err_count),ubar_a(1:err_count),&
                              vbar_a(1:err_count),wbar_a(1:err_count),tempr_a(1:err_count),&
                              tempr_u_a(1:err_count),tempr_v_a(1:err_count),tempr_w_a(1:err_count),&
                              mom3_u_a(1:err_count),mom3_v_a(1:err_count),mom3_w_a(1:err_count),mom4_u_a(1:err_count),&
                              mom4_v_a(1:err_count),mom4_w_a(1:err_count),mom5_u_a(1:err_count),mom5_v_a(1:err_count),&
                              mom5_w_a(1:err_count),mom6_u_a(1:err_count),mom6_v_a(1:err_count),mom6_w_a(1:err_count))
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       ! DIAGNOSTIC call to write on the hard drive the derivatives of macroparameters and the relaxation times of macroparameters.
       !!!!
       call WriteMomDerivRelaxTimes_DGV
       !!!!
       ! END DIAGNOSTIC
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      end if
      print *, "time step", time_step
     end do
     call cpu_time (pr_time_2) ! End the account of time
     print *, "Processor time lapsed in seconds for main run:", pr_time_2 - pr_time_1 ! Report the account of time
     !!! broadcast an  end of work code to the processors...
     call mpi_bcast (-777,1,MPI_INTEGER4,0,MPI_COMM_WORLD,ierr)  ! -777  means end of work
     if (ierr /= 0 ) then
       print *,"CheckSolutionMode_MPI_DGV: MPI boradcast of run_mode from proc 0 returned error", ierr
       stop
     end if
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 else  ! MPI FORK
     ! do this on the slave processor...
     ! need this scrape variables:
     allocate (fcol_scr(1:size(nodes_u,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "DGVblzm: Allocation error for variables (fcol_scr)"
     end if
     !
     ! Next the slave mode goes in the wait mode for the directives from the master node and exists there untill recieves the exist code -777
     do while (run_mode /= -777)
       ! First we wait for the transmission of the run_mode
        call mpi_bcast (run_mode,1,MPI_INTEGER4,0,MPI_COMM_WORLD,ierr)
        if (ierr /= 0 ) then
          print *,"DGVblzmPL: slave processor", irank, "MPI boradcast of run_mode from proc 0 returned error", ierr
        stop
        end if
        ! if the run_mode /= -777 we will need the solution
        if (run_mode /= -777) then
         ! we wait for the transmission of the solution
         nmsg=size(f,1)
         call mpi_bcast (f,nmsg,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
         if (ierr /= 0 ) then
          print *,"DGVblzmPL: slave processor", irank, "MPI boradcast of f from proc 0 returned error", ierr
         stop
         end if
        else
         print *, "run_mode = -777. stop next."
        end if
        ! nullify the scrap variables:
        fcol=0
        fcol_scr=0
        !
        !
        select case (run_mode)
         case (0) ! mode zero means we are in non-linear regime and collision integral needs to be computed.
          ! this little block releases memory used by the linearized operators
          if (BfmA_flag==1) then
            deallocate(BfmA)  ! release the memory used by the consolidated linear operator.
            BfmA_flag=0 ! set the flag into the "not allocated= 0"
          end if
          if (fmA_flag==1) then
            deallocate(fmA)  ! release the memory used by the consolidated linear operator.
            fmA_flag=0 ! set the flag into the "not allocated= 0"
          end if
          ! end of the memory release block...
          lin_no_update = 0 ! reset the counter for linerizaed steps with no update of the derivative
          ! this is a fully nonlinear case, we need to evaluate the portion of the collision integral
          call EvalCollisionPeriodicAPlus_MPI_DGV(f,fcol) !MPI FORK HERE
          ! see for the consolidated statement on mpi_reduce. Done the case of full nonlinear collision operator
         case (1) !
          ! this is the case when decomposition is used but no re-caclulation
          ! of the linearized operator is necessary
          ! we do not need to recalculate the Maxwellian (fm) -- it must be good to go somewhere in the memory:
          lin_no_update = 0 ! reset the counter for linerizaed steps with no update of the derivative
          Df=f-fm ! update the perturbatin of the Maxwellian
          call EvalCollisionLinear_MPI_DGV(Df,fcol_scr,procs_nodes_wld)  ! This evaluates the linear part
          call EvalCollisionPeriodicAPlus_MPI_DGV(Df,fcol) ! this evaluates the non-linear part
          fcol = fcol+fcol_scr ! this adds the linear and nonlinear parts
          ! see below for adding a dimensionless coefficient and for sending the solution out
         case (11)
          ! this is the case when decomposition is used but re-caclulation
          ! of the linearized operator is necessary
          ! this little block releases memory used by the linearized operators
          if (BfmA_flag==1) then
            deallocate(BfmA)  ! release the memory used by the consolidated linear operator.
            BfmA_flag=0 ! set the flag into the "not allocated= 0"
          end if
          ! end of the memory release block...
          lin_no_update = 0 ! reset the counter for linerizaed steps with no update of the derivative
          call MassCheckRec (f,ndens,ubar,vbar,wbar,tempr) ! First, we evaluate the macroparamters of the solution.
          fm = maxwelveldist(tempr,ubar,vbar,wbar,ndens,nodes_u, nodes_v, nodes_w) ! now we populate the maxwellian with the same macroparamters.
		  call PrepareFMA_MPI_DGV(irank) ! this will prepare the linearized operator  fmA = 2\int f_{m}(v)A(v,v_1,phi) dv
          !! Now we call the evaluation of the portion of the collision operator
          Df=f-fm ! update the perturbatin of the Maxwellian
          !!! Uncomment next line if need to remove using derivative of collision operator because of the storage limitaions.
          !!! call EvalCollisionPeriodicMixedTermsA_DGV(Df,fm,fcol_scr)
          call EvalCollisionLinear_MPI_DGV(Df,fcol_scr,procs_nodes_wld)  ! This evaluates the linear part using the derivative
          !!!!
          call EvalCollisionPeriodicAPlus_MPI_DGV(Df,fcol) ! this evaluates the non-linear part
          fcol = fcol+fcol_scr ! this adds the linear and nonlinear parts
          ! see below for adding a dimensionless coefficient and for sending the solution out
          !!!!!!!! DEBUG !!!!!!!!!!!!!!!!!!!!!
         case (2)
          ! this is the case when the solution is linearized, however, old linear operator can be used.
          lin_no_update = lin_no_update + 1
          ! if the number of linear steps is within the maximum allowed, evaluate the linearized solution and send it out
          if (lin_no_update <= num_linstep_wait) then
            ! evaluate the linearized solution
            Df=f-fm ! update the perturbatin of the Maxwellian
            call EvalCollisionLinear_MPI_DGV(Df,fcol,procs_nodes_wld)  ! This evaluates the linear part
          end if
          if (lin_no_update == num_linstep_wait+1) then
            ! else need to send out the pieces for the derivative for consolidation and if this is one of the
            ! processors that performs the consolidated evaluation of linear collision operator, then this will prepare fmA as well
            ! all is accomplished by the call of the subroutine:
            call PrepConsolLinColl_highperf_DGV(irank)  !! call the subroutine that sets up the consolidated linearized operator...
          end if
          if ((irank < num_lin_proc) .and. (lin_no_update > num_linstep_wait)) then
            ! evaluate the linearized solution
            Df=f-fm ! update the perturbatin of the Maxwellian
            call EvalConsolCollisionLinear_MPI_DGV(Df,fcol,lin_proc_nodes_wld)  ! This evaluates the linear part
          end if
         case (21)
           ! this is the case when the solution is linearized and the new linearized operator needs to be computed
           ! this little block releases memory used by the linearized operators
           if (BfmA_flag==1) then
            deallocate(BfmA)  ! release the memory used by the consolidated linear operator.
            BfmA_flag=0 ! set the flag into the "not allocated= 0"
           end if
           ! end of the memory release block...
           lin_no_update = 0 ! reset the counter for linerizaed steps with no update of the derivative
           call MassCheckRec (f,ndens,ubar,vbar,wbar,tempr) ! First, we evaluate the macroparamters of the solution.
           fm = maxwelveldist(tempr,ubar,vbar,wbar,ndens,nodes_u, nodes_v, nodes_w) ! now we populate the maxwellian with the same macroparamters.
		   call PrepareFMA_MPI_DGV(irank) ! this will prepare the linearized operator  fmA = 2\int f_{m}(v)A(v,v_1,phi) dv
           !! Now we call the evaluation of the portion of the collision operator
           Df=f-fm ! update the perturbatin of the Maxwellian
           call EvalCollisionLinear_MPI_DGV(Df,fcol,procs_nodes_wld)  ! This evaluates the linear part
         case (-777)
           print *,"DGVblzmPL: slave processor", irank, "end of work signal recieved. Exit now"
         case default
           print *,"DGVblzmPL: slave processor", irank, "Exit Error: unknown case of run_mode received, run_mode=", run_mode
           stop
        end select
        !!! These lines are consolidated from the sace select to minimize code repetition:
        !!! in all cases below the solution needs to be sent to the master node via mpi_reduce
        if ((run_mode == 0) .or. (run_mode == 1)  .or. (run_mode == 11)  .or. (run_mode == 21) &
                   .or. ((run_mode == 2) .and. (lin_no_update <= num_linstep_wait))) then
          ! Now we send back the portion of the collision integral
          nmsg=size(f,1)
          call mpi_reduce (fcol,f,nmsg,MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD,ierr) ! f for the receive buffer should be ignored
          if (ierr /= 0 ) then
           print *,"DGVblzmPL: slave processor", irank, "MPI_REDUCE to proc 0 returned error", ierr
           stop
          end if
        end if
        if (((run_mode == 2) .and. (lin_no_update > num_linstep_wait)) .and. (irank < num_lin_proc)) then
          ! Now we send back the portion of the collision integral
           nmsg=size(f,1)
          call mpi_reduce (fcol,f,nmsg,MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_LINEAR_COLL_WORLD,ierr) ! f for the receive buffer should be ignored
          if (ierr /= 0 ) then
           print *,"DGVblzmPL: slave processor", irank, "MPI_REDUCE to proc 0 returned error", ierr
           stop
          end if
        end if
        !! We sent the solution out
     end do
      print *, "slave process", irank, "exiting the main loop. Bye."

 end if
 !!! END MPI FORK
 !!!!!!!!!!!!!!!!!!!!!

call mpi_finalize(ierr)

end program main


C
C  Copyright 2017-2019 SALMON developers
C
C  Licensed under the Apache License, Version 2.0 (the "License");
C  you may not use this file except in compliance with the License.
C  You may obtain a copy of the License at
C
C      http://www.apache.org/licenses/LICENSE-2.0
C
C  Unless required by applicable law or agreed to in writing, software
C  distributed under the License is distributed on an "AS IS" BASIS,
C  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
C  See the License for the specific language governing permissions and
C  limitations under the License.
C
C======================================================================
C======================================================================
C
C     FFTE: A FAST FOURIER TRANSFORM PACKAGE
C
C     (C) COPYRIGHT SOFTWARE, 2000-2004, 2008-2014, ALL RIGHTS RESERVED
C                BY
C         DAISUKE TAKAHASHI
C         FACULTY OF ENGINEERING, INFORMATION AND SYSTEMS
C         UNIVERSITY OF TSUKUBA
C         1-1-1 TENNODAI, TSUKUBA, IBARAKI 305-8573, JAPAN
C         E-MAIL: daisuke@cs.tsukuba.ac.jp
C
C
C     PARALLEL 3-D COMPLEX FFT ROUTINE (WITH 2-D DECOMPOSITION)
C
C     FORTRAN77 + MPI SOURCE PROGRAM
C
C     CALL PZFFT3DV_MOD(A,B,NX,NY,NZ,NPUY,NPUZ,IOPT)
C            !!!!!!!!!!!!!!!!!ATTENTION!!!!!!!!!!!!!!!!! ! noda
C            ! Functions for ICOMMY and ICOMMZ are     ! ! noda
C            ! replaced to subroutines.                ! ! noda
C            !!!!!!!!!!!!!!!!!ATTENTION!!!!!!!!!!!!!!!!! ! noda
C
C     NX IS THE LENGTH OF THE TRANSFORMS IN THE X-DIRECTION (INTEGER*4)
C     NY IS THE LENGTH OF THE TRANSFORMS IN THE Y-DIRECTION (INTEGER*4)
C     NZ IS THE LENGTH OF THE TRANSFORMS IN THE Z-DIRECTION (INTEGER*4)
C       ------------------------------------
C         NX = (2**IP) * (3**IQ) * (5**IR)
C         NY = (2**JP) * (3**JQ) * (5**JR)
C         NZ = (2**KP) * (3**KQ) * (5**KR)
C       ------------------------------------
C     NPUY IS THE NUMBER OF PROCESSORS IN THE Y-DIRECTION (INTEGER*4)
C     NPUZ IS THE NUMBER OF PROCESSORS IN THE Z-DIRECTION (INTEGER*4)
C     IOPT = 0 FOR INITIALIZING THE COEFFICIENTS (INTEGER*4)
C     IOPT = -1 FOR FORWARD TRANSFORM WHERE
C              A(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX INPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE A(*,BLOCK,BLOCK)
C              B(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX OUTPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE B(*,BLOCK,BLOCK)
C     IOPT = +1 FOR INVERSE TRANSFORM WHERE
C              A(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX INPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE A(*,BLOCK,BLOCK)
C              B(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX OUTPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE B(*,BLOCK,BLOCK)
C     IOPT = -2 FOR FORWARD TRANSFORM WHERE
C              A(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX INPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE A(*,BLOCK,BLOCK)
C              B(NX/NPUY,NY/NPUZ,NZ) IS COMPLEX OUTPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE B(BLOCK,BLOCK,*)
C     IOPT = +2 FOR INVERSE TRANSFORM WHERE
C              A(NX/NPUY,NY/NPUZ,NZ) IS COMPLEX INPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE A(BLOCK,BLOCK,*)
C              B(NX,NY/NPUY,NZ/NPUZ) IS COMPLEX OUTPUT VECTOR (COMPLEX*16)
C!HPF$ DISTRIBUTE B(*,BLOCK,BLOCK)
C
C     WRITTEN BY DAISUKE TAKAHASHI
C
      SUBROUTINE PZFFT3DV_MOD(A,B,NX,NY,NZ,NPUY,NPUZ,IOPT)
      IMPLICIT REAL*8 (A-H,O-Z)
! Parameters written in param.h !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      PARAMETER (MAXNPU=65536)
      PARAMETER (NDA2=65536)
      PARAMETER (NDA3=4096)
      PARAMETER (NBLK=16)
      PARAMETER (NP=8)
      PARAMETER (L2SIZE=2097152)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      COMPLEX*16 A(*),B(*)
      COMPLEX*16 C(NDA3)
      COMPLEX*16 WX(NDA3),WY(NDA3),WZ(NDA3)
      DIMENSION LNX(3),LNY(3),LNZ(3)
      SAVE WX,WY,WZ
C
      NN=NX*(NY/NPUY)*(NZ/NPUZ)
C
      CALL FACTOR(NX,LNX)
      CALL FACTOR(NY,LNY)
      CALL FACTOR(NZ,LNZ)
C
      IF (IOPT .EQ. 0) THEN
        CALL SETTBL(WX,NX)
        CALL SETTBL(WY,NY)
        CALL SETTBL(WZ,NZ)
        RETURN
      END IF
C
      IF (IOPT .EQ. 1 .OR. IOPT .EQ. 2) THEN
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 10 I=1,NN
          A(I)=DCONJG(A(I))
   10   CONTINUE
      END IF
C
      IF (IOPT .EQ. -1 .OR. IOPT .EQ. -2) THEN
!$OMP PARALLEL PRIVATE(C)
        CALL PZFFT3DVF(A,A,A,A,A,A,A,B,B,B,B,B,B,B,C,WX,WY,WZ,NX,NY,NZ,
     1                 LNX,LNY,LNZ,NPUY,NPUZ,IOPT)
!$OMP END PARALLEL
      ELSE
!$OMP PARALLEL PRIVATE(C)
        CALL PZFFT3DVB(A,A,A,A,A,A,A,B,B,B,B,B,B,B,C,WX,WY,WZ,NX,NY,NZ,
     1                 LNX,LNY,LNZ,NPUY,NPUZ,IOPT)
!$OMP END PARALLEL
      END IF
C
      IF (IOPT .EQ. 1 .OR. IOPT .EQ. 2) THEN
        DN=1.0D0/(DBLE(NX)*DBLE(NY)*DBLE(NZ))
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 20 I=1,NN
          B(I)=DCONJG(B(I))*DN
   20   CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE PZFFT3DVF(A,AXYZP,AXZYP,AYZXP,AZPXY,AZXY,AZXY2,B,BXPYZ,
     1                     BXZYP,BYPZX,BYZX,BYZX2,BZXYP,C,WX,WY,WZ,
     2                     NX,NY,NZ,LNX,LNY,LNZ,NPUY,NPUZ,
     3                     IOPT)
      IMPLICIT REAL*8 (A-H,O-Z)
! Parameters written in param.h !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      PARAMETER (MAXNPU=65536)
      PARAMETER (NDA2=65536)
      PARAMETER (NDA3=4096)
      PARAMETER (NBLK=16)
      PARAMETER (NP=8)
      PARAMETER (L2SIZE=2097152)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      COMPLEX*16 A(NX,*),AXYZP(NX/NPUY,NY/NPUZ,NZ/NPUZ,*),
     1           AXZYP(NX/NPUY,NZ/NPUZ,NY/NPUY,*),
     2           AYZXP(NY/NPUY,(NZ/NPUZ)*(NX/NPUY),*),
     3           AZPXY(NZ/NPUZ,NPUZ,*),AZXY(NZ,*),
     4           AZXY2((NZ/NPUZ)*(NX/NPUY),*)
      COMPLEX*16 B((NX/NPUY)*(NY/NPUZ),*),BXPYZ(NX/NPUY,NPUY,NY/NPUY,*),
     1           BXZYP(NX/NPUY,NZ/NPUZ,NY/NPUZ,*),BYPZX(NY/NPUY,NPUY,*),
     2           BYZX(NY,*),BYZX2((NY/NPUY)*(NZ/NPUZ),*),
     3           BZXYP(NZ/NPUZ,(NX/NPUY)*(NY/NPUZ),*)
      COMPLEX*16 C(*)
      COMPLEX*16 WX(*),WY(*),WZ(*)
      DIMENSION LNX(*),LNY(*),LNZ(*)
C
      NNXY=NX/NPUY
      NNYY=NY/NPUY
      NNYZ=NY/NPUZ
      NNZZ=NZ/NPUZ
      NN=NX*NNYY*NNZZ
C
!$OMP DO
      DO 40 JJ=1,NNYY*NNZZ,NBLK
        DO 10 J=JJ,MIN0(JJ+NBLK-1,NNYY*NNZZ)
          CALL FFT235(A(1,J),C,WX,NX,LNX)
   10   CONTINUE
        DO 30 I=1,NX
!DIR$ VECTOR ALIGNED
          DO 20 J=JJ,MIN0(JJ+NBLK-1,NNYY*NNZZ)
            BYZX2(J,I)=A(I,J)
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(BYZX2,NN/NPUY,MPI_DOUBLE_COMPLEX,AYZXP,NN/NPUY,
C     1                  MPI_DOUBLE_COMPLEX,ICOMMY,IERR)
      CALL CONVERT_1D_Y(BYZX2,AYZXP,NN,NPUY)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 70 K=1,NNZZ*NNXY
        DO 60 L=1,NPUY
!DIR$ VECTOR ALIGNED
          DO 50 J=1,NNYY
            BYPZX(J,L,K)=AYZXP(J,K,L)
   50     CONTINUE
   60   CONTINUE
   70 CONTINUE
!$OMP DO
      DO 110 KK=1,NNZZ*NNXY,NBLK
        DO 80 K=KK,MIN0(KK+NBLK-1,NNZZ*NNXY)
          CALL FFT235(BYZX(1,K),C,WY,NY,LNY)
   80   CONTINUE
        DO 100 J=1,NY
!DIR$ VECTOR ALIGNED
          DO 90 K=KK,MIN0(KK+NBLK-1,NNZZ*NNXY)
            AZXY2(K,J)=BYZX(J,K)
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(AZXY2,NN/NPUZ,MPI_DOUBLE_COMPLEX,BZXYP,
C     1                  NN/NPUZ,MPI_DOUBLE_COMPLEX,ICOMMZ,IERR)
      CALL CONVERT_1D_Z(AZXY2,BZXYP,NN,NPUZ)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 140 I=1,NNXY*NNYZ
        DO 130 L=1,NPUZ
!DIR$ VECTOR ALIGNED
          DO 120 K=1,NNZZ
            AZPXY(K,L,I)=BZXYP(K,I,L)
  120     CONTINUE
  130   CONTINUE
        CALL FFT235(AZPXY(1,1,I),C,WZ,NZ,LNZ)
  140 CONTINUE
!$OMP DO
      DO 180 JJ=1,NZ,NBLK
        DO 170 II=1,NNXY*NNYZ,NBLK
          DO 160 J=JJ,MIN0(JJ+NBLK-1,NZ)
!DIR$ VECTOR ALIGNED
            DO 150 I=II,MIN0(II+NBLK-1,NNXY*NNYZ)
              B(I,J)=AZXY(J,I)
  150       CONTINUE
  160     CONTINUE
  170   CONTINUE
  180 CONTINUE
      IF (IOPT .EQ. -2) RETURN
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(B,NN/NPUZ,MPI_DOUBLE_COMPLEX,AXYZP,NN/NPUZ,
C     1                  MPI_DOUBLE_COMPLEX,ICOMMZ,IERR)
      call CONVERT_1D_Z(B,AXYZP,NN,NPUZ)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 220 L=1,NPUZ
        DO 210 J=1,NNYZ
          DO 200 K=1,NNZZ
!DIR$ VECTOR ALIGNED
            DO 190 I=1,NNXY
              BXZYP(I,K,J,L)=AXYZP(I,J,K,L)
  190       CONTINUE
  200     CONTINUE
  210   CONTINUE
  220 CONTINUE
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(BXZYP,NN/NPUY,MPI_DOUBLE_COMPLEX,AXZYP,NN/NPUY,
C     1                  MPI_DOUBLE_COMPLEX,ICOMMY,IERR)
      call CONVERT_1D_Y(BXZYP,AXZYP,NN,NPUY)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 260 K=1,NNZZ
        DO 250 J=1,NNYY
          DO 240 L=1,NPUY
!DIR$ VECTOR ALIGNED
            DO 230 I=1,NNXY
              BXPYZ(I,L,J,K)=AXZYP(I,K,J,L)
  230       CONTINUE
  240     CONTINUE
  250   CONTINUE
  260 CONTINUE
      RETURN
      END
      SUBROUTINE PZFFT3DVB(A,AXPYZ,AXZYP,AYPZX,AYZX,AYZX2,AZXYP,B,BXYZP,
     1                     BXZYP,BYZXP,BZPXY,BZXY,BZXY2,C,WX,WY,WZ,
     2                     NX,NY,NZ,LNX,LNY,LNZ,NPUY,NPUZ,
     3                     IOPT)
      IMPLICIT REAL*8 (A-H,O-Z)
! Parameters written in param.h !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      PARAMETER (MAXNPU=65536)
      PARAMETER (NDA2=65536)
      PARAMETER (NDA3=4096)
      PARAMETER (NBLK=16)
      PARAMETER (NP=8)
      PARAMETER (L2SIZE=2097152)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      COMPLEX*16 A((NX/NPUY)*(NY/NPUZ),*),AXPYZ(NX/NPUY,NPUY,NY/NPUY,*),
     1           AXZYP(NX/NPUY,NZ/NPUZ,NY/NPUZ,*),
     2           AYPZX(NY/NPUY,NPUY,*),AYZX(NY,*),
     3           AYZX2((NY/NPUY)*(NZ/NPUZ),*),
     4           AZXYP(NZ/NPUZ,(NX/NPUY)*(NY/NPUZ),*)
      COMPLEX*16 B(NX,*),BXYZP(NX/NPUY,NY/NPUZ,NZ/NPUZ,*),
     1           BXZYP(NX/NPUY,NZ/NPUZ,NY/NPUY,*),
     2           BYZXP(NY/NPUY,(NZ/NPUZ)*(NX/NPUY),*),
     3           BZPXY(NZ/NPUZ,NPUZ,*),BZXY(NZ,*),
     4           BZXY2((NZ/NPUZ)*(NX/NPUY),*)
      COMPLEX*16 C(*)
      COMPLEX*16 WX(*),WY(*),WZ(*)
      DIMENSION LNX(*),LNY(*),LNZ(*)
C
      NNXY=NX/NPUY
      NNYY=NY/NPUY
      NNYZ=NY/NPUZ
      NNZZ=NZ/NPUZ
      NN=NNXY*NNYZ*NZ
C
      IF (IOPT .EQ. 1) THEN
!$OMP DO
        DO 40 L=1,NPUY
          DO 30 J=1,NNYY
            DO 20 K=1,NNZZ
!DIR$ VECTOR ALIGNED
              DO 10 I=1,NNXY
                BXZYP(I,K,J,L)=AXPYZ(I,L,J,K)
   10         CONTINUE
   20       CONTINUE
   30     CONTINUE
   40   CONTINUE
!$OMP BARRIER
!$OMP MASTER
C        CALL MPI_ALLTOALL(BXZYP,NN/NPUY,MPI_DOUBLE_COMPLEX,AXZYP,
C     1                    NN/NPUY,MPI_DOUBLE_COMPLEX,ICOMMY,IERR)
      call CONVERT_1D_Y(BXZYP,AXZYP,NN,NPUY)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
        DO 80 L=1,NPUZ
          DO 70 K=1,NNZZ
            DO 60 J=1,NNYZ
!DIR$ VECTOR ALIGNED
              DO 50 I=1,NNXY
                BXYZP(I,J,K,L)=AXZYP(I,K,J,L)
   50         CONTINUE
   60       CONTINUE
   70     CONTINUE
   80   CONTINUE
!$OMP BARRIER
!$OMP MASTER
C        CALL MPI_ALLTOALL(BXYZP,NN/NPUZ,MPI_DOUBLE_COMPLEX,A,NN/NPUZ,
C     1                    MPI_DOUBLE_COMPLEX,ICOMMZ,IERR)
      call CONVERT_1D_Z(BXYZP,A,NN,NPUZ)
!$OMP END MASTER
!$OMP BARRIER
      END IF
C
!$OMP DO
      DO 120 II=1,NNXY*NNYZ,NBLK
        DO 110 JJ=1,NZ,NBLK
          DO 100 I=II,MIN0(II+NBLK-1,NNXY*NNYZ)
!DIR$ VECTOR ALIGNED
            DO 90 J=JJ,MIN0(JJ+NBLK-1,NZ)
              BZXY(J,I)=A(I,J)
   90       CONTINUE
  100     CONTINUE
  110   CONTINUE
  120 CONTINUE
!$OMP DO
      DO 150 I=1,NNXY*NNYZ
        CALL FFT235(BZPXY(1,1,I),C,WZ,NZ,LNZ)
        DO 140 L=1,NPUZ
!DIR$ VECTOR ALIGNED
          DO 130 K=1,NNZZ
            AZXYP(K,I,L)=BZPXY(K,L,I)
  130     CONTINUE
  140   CONTINUE
  150 CONTINUE
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(AZXYP,NN/NPUZ,MPI_DOUBLE_COMPLEX,BZXY2,NN/NPUZ,
C     1                  MPI_DOUBLE_COMPLEX,ICOMMZ,IERR)
      CALL CONVERT_1D_Z(AZXYP,BZXY2,NN,NPUZ)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 190 KK=1,NNZZ*NNXY,NBLK
        DO 170 K=KK,MIN0(KK+NBLK-1,NNZZ*NNXY)
!DIR$ VECTOR ALIGNED
          DO 160 J=1,NY
            AYZX(J,K)=BZXY2(K,J)
  160     CONTINUE
  170   CONTINUE
        DO 180 K=KK,MIN0(KK+NBLK-1,NNZZ*NNXY)
          CALL FFT235(AYZX(1,K),C,WY,NY,LNY)
  180   CONTINUE
  190 CONTINUE
!$OMP DO
      DO 220 L=1,NPUY
        DO 210 K=1,NNZZ*NNXY
!DIR$ VECTOR ALIGNED
          DO 200 J=1,NNYY
            BYZXP(J,K,L)=AYPZX(J,L,K)
  200     CONTINUE
  210   CONTINUE
  220 CONTINUE
!$OMP BARRIER
!$OMP MASTER
C      CALL MPI_ALLTOALL(BYZXP,NN/NPUY,MPI_DOUBLE_COMPLEX,AYZX2,NN/NPUY,
C     1                  MPI_DOUBLE_COMPLEX,ICOMMY,IERR)
      CALL CONVERT_1D_Y(BYZXP,AYZX2,NN,NPUY)
!$OMP END MASTER
!$OMP BARRIER
!$OMP DO
      DO 260 JJ=1,NNYY*NNZZ,NBLK
        DO 240 J=JJ,MIN0(JJ+NBLK-1,NNYY*NNZZ)
!DIR$ VECTOR ALIGNED
          DO 230 I=1,NX
            B(I,J)=AYZX2(J,I)
  230     CONTINUE
  240   CONTINUE
        DO 250 J=JJ,MIN0(JJ+NBLK-1,NNYY*NNZZ)
          CALL FFT235(B(1,J),C,WX,NX,LNX)
  250   CONTINUE
  260 CONTINUE
      RETURN
      END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE CONVERT_1D_Y(A,B,NN,NPUY)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(*),B(*)

      CALL ALLTOALL_1D_Y(A,B,NN,NPUY)

      END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE CONVERT_1D_Z(A,B,NN,NPUZ)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(*),B(*)

      CALL ALLTOALL_1D_Z(A,B,NN,NPUZ)

      END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


!======================
! 1D euler eq.
!=====================
program Euler

    implicit none

    real(8) :: CFL, time_max, eosGamma, eosCp, len, dx, &
     time, charVel, wL(3), wR(3), vecSf, dPN, avgDp, underRelaxFactP, &
     timestep, timestepMax, resiP, fVol, gP, gF, resiU, &
     maxP,minP,maxU,minU,dPF,segAlp
    real(8), dimension(:), allocatable :: cX, cRho, cU, cP, cT, &
     cVol, cDt, area, fMdot, fU, fP, fT, cAcRU, cAfRU, cBcRU, &
     cAcUU, cAfUU, cAfUP, cBcUU, cDrDp, cHt, &
     fDrDp, fRho, fFirPE, fAcUU, fSecPE, fDp_fS, &
     cAcPDp, cAfPR, cAfPDp, cBcPDp, cDp, &
     fHt, cAcHH, cAfHU, cBcHH, fThrPE, fDpDn, fDp, cDU, &
     fUx, cEt, fEt, cC, cGECon, cGEMom, cGEEnr, &
     fGEConFlux, fGEMomFlux, fGEEnrFlux, segBmat
    real(8), dimension(:,:), allocatable :: segAmat
    integer :: nCell, nCellStr, nCellEnd, nTCellStr, nTCellEnd, &
     nFace, nFaceStr, nFaceEnd, i, nstep, lFace, rFace, iterSIMPLE, &
     iterMaxSIMPLE, lCell, rCell, iterPISO, iterMaxPISO

    CFL = 0.1
    nCell = 100
    time_max = 0.012 !sec
    eosGamma = 1.4 ! air
    eosCp = 1006.d0
    len = 1.0 ! m, x-length
    iterMaxSIMPLE = 100
    underRelaxFactP = 0.1d0
    !timestepMax = 1.d-2
    timestep = 1.d-2

    nCellStr = 1
    nCellEnd = nCell

    nTCellStr = 0
    nTCellEnd = nCell + 1
    allocate( cX(nTCellStr:nTCellEnd), &
              cRho(nTCellStr:nTCellEnd), &
              cU(nTCellStr:nTCellEnd), &
              cP(nTCellStr:nTCellEnd), &
              cT(nTCellStr:nTCellEnd), &
              cDt(nTCellStr:nTCellEnd), &
              cVol(nTCellStr:nTCellEnd), &
              cAcRU(nTCellStr:nTCellEnd), &
              cAfRU(nTCellStr:nTCellEnd), &
              cBcRU(nTCellStr:nTCellEnd), &
              cAcUU(nTCellStr:nTCellEnd), &
              cAfUU(nTCellStr:nTCellEnd), &
              cAfUP(nTCellStr:nTCellEnd), &
              cBcUU(nTCellStr:nTCellEnd), &
              cDrDp(nTCellStr:nTCellEnd), &
              cHt(nTCellStr:nTCellEnd), &
              cAcPDp(nTCellStr:nTCellEnd), &
              cAfPR(nTCellStr:nTCellEnd), &
              cAfPDp(nTCellStr:nTCellEnd), &
              cBcPDp(nTCellStr:nTCellEnd), &
              cDp(nTCellStr:nTCellEnd), &
              cAcHH(nTCellStr:nTCellEnd), &
              cAfHU(nTCellStr:nTCellEnd), &
              cBcHH(nTCellStr:nTCellEnd), &
              cDu(nTCellStr:nTCellEnd), &
              cEt(nTCellStr:nTCellEnd), &
              cC(nTCellStr:nTCellEnd), &
              cGECon(nTCellStr:nTCellEnd), &
              cGEMom(nTCellStr:nTCellEnd), &
              cGEEnr(nTCellStr:nTCellEnd) )
    cDP(:) = 0.d0

    nFace = nCell+1
    nFaceStr = 0
    nFaceEnd = nCell
    allocate( fP(nFaceStr:nFaceEnd), &
              fU(nFaceStr:nFaceEnd), &
              fT(nFaceStr:nFaceEnd), &
              area(nFaceStr:nFaceEnd), &
              fMdot(nFaceStr:nFaceEnd), &
              fDrDp(nFaceStr:nFaceEnd), &
              fRho(nFaceStr:nFaceEnd), &
              fFirPE(nFaceStr:nFaceEnd), &
              fAcUU(nFaceStr:nFaceEnd), &
              fSecPE(nFaceStr:nFaceEnd), &
              fDp_fS(nFaceStr:nFaceEnd), &
              fHt(nFaceStr:nFaceEnd), &
              fDpDn(nFaceStr:nFaceEnd), &
              fThrPE(nFaceStr:nFaceEnd), &
              fDp(nFaceStr:nFaceEnd), &
              fUx(nFaceStr:nFaceEnd), &
              fEt(nFaceStr:nFaceEnd), &
              fGEConFlux(nFaceStr:nFaceEnd), &
              fGEMomFlux(nFaceStr:nFaceEnd), &
              fGEEnrFlux(nFaceStr:nFaceEnd) )

    allocate( segAmat(nCellEnd,nCellEnd), &
              segBmat(nCellEnd) )

    !-------- one-dimensional Mesh
    dx = len/real(ncell,8)
    do i=nTCellStr,nTCellEnd
      ! x value of cell center point
      cX(i) = 0.5d0*dx + (real(i,8)-1.d0)*dx
      cVol(i) = dx*1.d0*1.d0
    enddo
    do i=nFaceStr,nFaceEnd
      area(i) = 1.d0
    enddo

    !-------- initial condition
    ! w=(rho,u,p), primitive variables
    do i=nTCellStr,nTCellEnd
      !> sod shock condition
      if( cX(i) < 0.8d0 ) then
          cRho(i) = 1.000d0
          cU(i)   = 0.000d0
          cP(i)   = 1.000d0
      else
          cRho(i) = 0.125d0
          cU(i)   = 0.000d0
          cP(i)   = 0.100d0
      endif
    enddo
    !--------- Ht, Et, T, c from EOS
    do i=nTCellStr,nTCellEnd
        cT(i) = cP(i)/cRho(i)/eosCp/(1.d0-1.d0/eosGamma)
        cHt(i) = eosCp*cT(i) + 0.5d0*(cU(i)**2.d0)
        cEt(i) = cHt(i) - cP(i)/cRho(i)
        cC(i) = dsqrt(eosGamma*cP(i)/cRho(i))
        cDrDp(i) = 1.d0/eosCp/(1.d0-1.d0/eosGamma)/cT(i)
    enddo

    time = 0.d0
    nstep=0

    do while( time <= time_max )

        nstep=nstep+1

        !!---- calculation time-step
        !do i=nCellStr,nCellEnd
        !    lFace = i-1
        !    rFace = i
        !    charVel = dabs(cU(i))*dmax1(area(lFace),area(rFace))
        !    cDt(i) = dmin1( timestepMax, CFL*cVol(i)/charVel ) ! sec
        !   ! print*,cVol(i)/((dabs(cU(i))+cC(i))*dmax1(area(lFace),area(rFace)))
        !enddo
        !timestep = minval(cDt(nCellStr:nCellEnd))
        cDt(:) = timestep

        !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        !------------ Density based solver ----
        !=======================================================
        !> Variables initialization AUSM+
        !> mass flow rate, velocity, pressure of cell interface
        do i=nFaceStr,nFaceEnd
            lCell = i
            rCell = i+1
            wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
            wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
            CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
            fMdot(i) = fMdot(i)*area(i)
            gP = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
            gF = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
            fUx(i) = gP*cU(lCell)  + gF*cU(rCell)

            if( fMdot(i) >= 0.d0 ) then
                fGEConFlux(i) = fMdot(i)
                fGEMomFlux(i) = fMdot(i)*cU(lCell) !+ fP(i)*area(i)
                fGEEnrFlux(i) = fMdot(i)*cHt(lCell)
            else
                fGEConFlux(i) = fMdot(i)
                fGEMomFlux(i) = fMdot(i)*cU(rCell) !+ fP(i)*area(i)
                fGEEnrFlux(i) = fMdot(i)*cHt(rCell)
            endif
        enddo
        !=======================================================
        !> Update to Gorverning Equations
        do i=nCellStr,nCellEnd
            lFace = i-1
            rFace = i

            cGECon(i) = cRho(i) &
                      + cDt(i)/cVol(i)*( fGEConFlux(rFace) - fGEConFlux(lFace) )
            cGEMom(i) = cRho(i)*cU(i) &
                      + cDt(i)/cVol(i)*( fGEMomFlux(rFace) - fGEMomFlux(lFace) )
            cGEEnr(i) = cRho(i)*cEt(i) &
                      + cDt(i)/cVol(i)*( fGEEnrFlux(rFace) - fGEEnrFlux(lFace) )

        enddo
        !=======================================================
        !> Pressure, Speed of Sound, Density
        do i=nCellStr,nCellEnd
            lFace = i-1
            rFace = i

            cRho(i) = cGECon(i)
            cU(i) = cGEMom(i)/cRho(i)
            cP(i) = (cGEEnr(i) - 0.5d0*cRho(i)*cU(i)**2.d0)*(eosGamma-1.d0)
            cC(i) = dsqrt(eosGamma*cP(i)/cRho(i))
           ! cDrDp(i) = 1.d0/eosCp/(1.d0-1.d0/eosGamma)/cT(i)

        enddo
        cRho(0) = cRho(1); cRho(ncell) = cRho(ncell-1)
        cU(0) = cU(1); cU(ncell) = cU(ncell-1)
        cP(0) = cP(1); cP(ncell) = cP(ncell-1)

        !=======================================================
        do i=nFaceStr,nFaceEnd
            lCell = i
            rCell = i+1

            wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
            wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
            CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
            fMdot(i) = fMdot(i)*area(i)
        enddo

        !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        !----------------- Segregated Method ----------------
        Segregated: do iterSIMPLE = 1,iterMaxSIMPLE

            segAmat(:,:) = 0.d0
            do i=nCellStr,nCellEnd
                lFace = i-1
                rFace = i

                dPF = dx

                if( i-1 >= nCellStr ) then
                    segAlp = area(lFace)*cDt(i-1) &
                             /(0.5d0*(cRho(i-1)+cRho(i))) &
                             /dPF
                    segAmat(i,i-1) = segAlp
                    segAmat(i,i)   = segAmat(i,i) -segAlp
                endif
                if( i+1 <= nCellEnd ) then
                    segAlp = area(rFace)*cDt(i+1) &
                            /(0.5d0*(cRho(i+1)+cRho(i))) &
                            /dPF
                    segAmat(i,i+1) = segAlp
                    segAmat(i,i)   = segAmat(i,i) -segAlp
                endif
                segAmat(i,i) = segAmat(i,i) - 1.d0/cRho(i)*cDrDp(i)/cDt(i)

                segBmat(i) = area(lFace) * ( fU(lFace) - cDt(i) &
                             /(0.5d0*(cRho(i-1)+cRho(i))) &
                              *( (cDp(i-1)-cDp(i))/dPF ) ) &
                           + area(rFace) * ( fU(rFace) - cDt(i) &
                             /(0.5d0*(cRho(i+1)+cRho(i))) &
                              *( (cDp(i+1)-cDp(i))/dPF ) )

            enddo

            CALL matInverse(segAmat,nCellEnd)

            !cDp(1:nCellEnd) = matmul(segAmat(:,:),segBmat(:))
            do i=nCellStr,nCellEnd
                cDp(i) = sum(segAmat(i,:)*segBmat(:))
            enddo

            resiP = 0.d0
            do i=nCellStr,nCellEnd
                if( i-1 >= nCellStr ) then
                    resiP = resiP + (cDp(i)-cDp(i-1))**2.d0*area(i-1)
                endif
                if( i+1 <= nCellEnd ) then
                    resiP = resiP + (cDp(i)-cDp(i+1))**2.d0*area(i)
                endif
            enddo
            print*,iterSIMPLE,resiP
            !stop

            !=======================================================

        enddo Segregated !> End iteration SIMPLE

        do i=nCellStr,nCellEnd
            cGECon(i) = cGECon(i) - cDt(i)*cDp(i)
        enddo

        time = time + timestep

    !/////////////////////////////////
        print*,nstep,time
    !/////////////////////////////////

    enddo

    !/////////////////////////////////
    open(20,file='a.dat')!,status='old',position='append')
    do i=nCellStr,nCellEnd
        WRITE( 20, '(20(F20.9, 1X))' ) cX(i),cRho(i),cU(i),cP(i)
    enddo
    close(20)
    !/////////////////////////////////

100 format(i7,1x,6(1pe10.2))

end program Euler

subroutine calfaceValAUSM(wL,wR,gamma, mLR,uLR,pLR)

    implicit none

    real(8), dimension(3), intent(in) :: wL, wR
    real(8), intent(in) :: gamma
    real(8), intent(out):: mLR,uLR,pLR
    real(8) :: rho_L,rho_R,u_L,u_R,p_L,p_R,c_L,c_R, &
    H_L,H_R,chat,M_L,M_R,MLP,preP,MRM,preM,mdot

    ! AUSM+ scheme
    ! wL : left value of cell interface (face)
    ! wR : right
    rho_L = wL(1); rho_R = wR(1)
    u_L = wL(2); u_R = wR(2)
    p_L = wL(3); p_R = wR(3)

    c_L = sqrt(gamma*p_L/rho_L); c_R = sqrt(gamma*p_R/rho_R)
    H_L = gamma/(gamma-1.d0)*p_L/rho_L+0.5d0*u_L**2.d0
    H_R = gamma/(gamma-1.d0)*p_R/rho_R+0.5d0*u_R**2.d0
    !----------------------------------------------------

    chat = 0.5d0*(c_L+c_R)
    M_L = u_L/chat; M_R = u_R/chat

    !------ numerical mass flux & pressure flux in AUSM+ scheme ------
    if( abs(M_L) > 1.0 ) then
        MLP = 0.5*(M_L+abs(M_L))
        preP = 0.5*(1.0+sign(1.0,M_L))
    else
        MLP = 0.25*(M_L+1.0)**2.0
        preP = 0.25*(M_L+1.0)**2.0*(2.0-M_L)
    endif

    if( abs(M_R) > 1.0 ) then
        MRM = 0.5*(M_R-abs(M_R))
        preM = 0.5*(1.0-sign(1.0,M_R))
    else
        MRM = -0.25*(M_R-1.0)**2.0
        preM = 0.25*(M_R-1.0)**2.0*(2.0+M_R)
    endif

    uLR = (MLP + MRM)*chat

    if( uLR>=0.d0 ) then
        mLR = rho_L*uLR
    else
        mLR = rho_R*uLR
    endif

    pLR = preP*p_L+preM*p_R

    endsubroutine

!============================================================
!> Inverse matrix
!! Method: Based on Doolittle LU factorization for Ax=b
!! Original code by Alex G. December 2009
!! modified by Jongchan Kim 2018
!!-----------------------------------------------------------
!! input ...
!! a(n,n) - array of coefficients for matrix A
!! n      - dimension
!! output ...
!! a(n,n) - inverse matrix of A
!! comments ...
!! the original matrix a(n,n) will be destroyed
!! during the calculation
!!===========================================================
subroutine matInverse(a,n)

    implicit none
    integer :: n
    real(8) :: a(n,n)
    real(8) :: L(n,n), U(n,n), b(n), d(n), x(n)
    real(8) :: coeff
    integer :: i, j, k

    ! step 0: initialization for matrices L and U and b
    ! Fortran 90/95 aloows such operations on matrices
    L=0.d0
    U=0.d0
    b=0.d0

    ! step 1: forward elimination
    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

    ! Step 2: prepare L and U matrices
    ! L matrix is a matrix of the elimination coefficient
    ! + the diagonal elements are 1.0
    do i=1,n
        L(i,i) = 1.d0
    end do
    ! U matrix is the upper triangular part of A
    do j=1,n
        do i=1,j
            U(i,j) = a(i,j)
        end do
    end do

    ! Step 3: compute columns of the inverse matrix C
    do k=1,n
        b(k)=1.d0
        d(1) = b(1)
        ! Step 3a: Solve Ld=b using the forward substitution
        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
        ! Step 3b: Solve Ux=d using the back substitution
        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
        ! Step 3c: fill the solutions x(n) into column k of C
        do i=1,n
            a(i,k) = x(i)
        end do
        b(k)=0.d0
    end do
end subroutine matInverse


 SUBROUTINE nodn07( nelem,lnods,coord,eule0,euler)
 !******************************************************************************
 !
 !****this routine compute the position angles of the nodal coordinate systems
 !
 !     input:   nelem:         number of elements
 !              coord:         nodal coordinates
 !              lnods:         element conectivities
 !              euler:  /= 0   angles of the nodes. not modified
 !                      == 0   nodes where to compute euler angles
 !
 !     output:  euler:  angles of the nodes.
 !
 !******************************************************************************
 IMPLICIT NONE

 INTEGER (kind=4), PARAMETER :: nd = 3
 INTEGER (kind=4), INTENT(IN) :: nelem,lnods(:,:)
 REAL (kind=8), INTENT(IN) :: coord(:,:)
 REAL (kind=8), INTENT(IN OUT) :: eule0(:,:),euler(:,:)

 INTEGER (kind=4)ipoin,ielem,inode,npoin
 REAL (kind=8)  auxil,lbd(nd,nd),area,             &
                x(nd,3),ll(nd,3),t3(nd)

 REAL (kind=8), ALLOCATABLE :: vecnx(:,:),vecnz(:,:)
 INTERFACE
   INCLUDE 'angeul.h'
 END INTERFACE
 !     initialize normal z' and x' vectors
 npoin = MAXVAL(lnods)
 ALLOCATE ( vecnx(nd,npoin), vecnz(nd,npoin) )
 vecnx = 0d0
 vecnz = 0d0

 !     summ elemental z' and x'

 DO ielem=1,nelem
   x(1:nd,1:3) = coord(1:nd,lnods(1:3,ielem))
   !*** evaluate the first two side vectors
   !
   ll(:,1) = x(:,3) - x(:,2)                             !side 1
   ll(:,2) = x(:,1) - x(:,3)                             !side 2
   ll(:,3) = x(:,2) - x(:,1)                             !side 3

   !*** evaluate the cross product => plane normal

   CALL vecpro(ll(1,1),ll(1,2),t3)                  !normal * area2
   CALL vecuni(3,t3,area)                           !normalizes vector

   DO ipoin=1,3
     inode = lnods(ipoin+3,ielem)
     vecnz(:,inode) = vecnz(:,inode) + t3/area
     vecnx(:,inode) = vecnx(:,inode) + ll(:,ipoin)
   END DO
 END DO

 !     compute euler's angles asociated to nodal coordinate system

 DO ipoin=1,npoin
   !   check if Euler angles exist
   IF( .NOT.ALL( eule0(1:3,ipoin) == 0d0) ) CYCLE
   !   average normal vector
   lbd(1:nd,3) = vecnz(1:nd,ipoin)
   CALL vecuni(nd,lbd(1,3),auxil)
   !   if node do NOT have associated elements
   IF(auxil == 0d0) CYCLE
   lbd(1:nd,1) = vecnx(1:nd,ipoin)
   CALL vecuni(nd,lbd(1,1),auxil)
   IF( ABS(auxil) > 1d-8 ) THEN
     ! IF it is a border node
     ! make surface normal perpendicular to direction X
     auxil = DOT_PRODUCT(lbd(1:3,1),lbd(1:3,3))
     lbd(1:nd,3) = lbd(1:nd,3) - auxil*lbd(1:nd,1)
     CALL vecuni(nd,lbd(1,3),auxil)
     CALL vecpro(lbd(1,3),lbd(1,1),lbd(1,2))
   ELSE
     ! IF it is an internal node
     !         SELECT local x=t1 in the global xy plane
     lbd(1:nd,1) = (/ -lbd(2,3), lbd(1,3) , 0d0 /)
     !         of course local y = t2 = t3 x t1
     lbd(1:nd,2) = (/ -lbd(1,3)*lbd(3,3), -lbd(2,3)*lbd(3,3), &
                      (lbd(1,3)*lbd(1,3) + lbd(2,3)*lbd(2,3)) /)
     !         IF t3 is just global Z
     IF(ABS(lbd(3,2)) < 1.0d-5) THEN
       lbd(1:nd,1) = (/  1d0, 0d0, 0d0 /)
       lbd(1:nd,2) = (/  0d0, 1d0, 0d0 /)
     ELSE
       !           normalizes t1 & t2
       CALL vecuni(nd,lbd(1,1),auxil)
       CALL vecuni(nd,lbd(1,2),auxil)
     END IF
   END IF
   CALL angeul(lbd,eule0(1:3,ipoin),.TRUE.)
   euler(1:3,ipoin) = eule0(1:3,ipoin)
 END DO
 DEALLOCATE ( vecnx, vecnz )

 RETURN
 END SUBROUTINE nodn07


      subroutine leq1s (a,n,b,m,ib,ijob,wa,ier)
!-------------------------------------------------------------
!
!   latest revision     - april 19, 1993
!
!   purpose             - linear equation solution -
!                           indefinite matrix - symmetric
!                           storage mode - space economizer
!                           solution
!
!   usage               - call leq1s (a,n,b,m,ib,ijob,wa,ier)
!
!   arguments    a      - input/output vector of dimension
!                           n*(n+1)/2. see parameter ijob.
!                n      - order of matrix a and the number of
!                           rows in b. (input)
!                b      - input/output matrix of dimension n
!                           by m. on input, b contains the m
!                           right-hand sides of the equation
!                           ax = b. on output, the solution
!                           matrix x replaces b. if ijob = 1,
!                           b is not used.
!                m      - number of right hand sides (columns
!                           in b). (input)
!                ib     - column dimension of b exactly as
!                           specified in the dimension
!                           statement in the calling program.
!                           (input)
!                ijob   - input option parameter. ijob = i
!                           implies when
!                           i = 0, factor the matrix a and
!                             solve the equation ax = b. on
!                             input, a contains the coefficient
!                             matrix of the equation ax = b,
!                             where a is assumed to be an
!                             n by n symmetric matrix. a is
!                             stored in symmetric storage mode
!                             and therefore has dimension
!                             n*(n+1)/2. on output, a is
!                             replaced by its factorized form.
!                           i = 1, factor the matrix a.
!                             a contains the same input/output
!                             information as if ijob = 0. b is
!                             not used.
!                           i = 2, solve the equation ax = b.
!                             this option implies that leq1s
!                             has already been called using
!                             ijob = 0 or 1 so that the matrix
!                             a has already been factored.
!                             in this case, output matrix a
!                             must have been saved for reuse
!                             in the call to leq1s.
!                wa     - work area of length n+1,
!                           on output wa(n+1) contains the
!                           number of eigenvalues below zero
!                ier    - error parameter. (output)
!                         warning error (with fix)
!                           ier = 65 indicates that matrix a
!                             is algorithmically singular.
!                         terminal error
!                           ier = 129 indicates that matrix a
!                             is exactly singular on one step
!                             of procedure.
!
!-------------------------------------------------------------
      implicit real (16) (a-h,o-z)
      dimension          a(*),b(ib,*),wa(*)
      real (16)     :: zero=0.0q0
      real (16)     :: alpha=0.6403882q0
      real (16)     :: sixtn=16.0q0
      save               zero,alpha,sixtn
!
!                                  first executable statement
!                                    initialize ier
!
      ier = 0
!
!   ****  first stage  ****        decompose a into the
!                                    product m*d*m-transpose
!                                    where m is unit lower
!                                    triangular and d is block
!                                    diagonal with blocks of
!                                    order 1 or 2.
!                                    m and d are written over a.
!
      if (n.le.0) goto 9005
      if (ijob.eq.2) goto 80
!
!                                  calculate equilibration
!                                    factors
!
      rn = sixtn*n
      wa(n+1) = 0
      ll = 1
      do 10 i=1,n
         wa(i) = zero
         l = ll
         do 5 j=1,n
            temp = abs(a(l))
            if (temp.gt.wa(i)) wa(i) = temp
            if (j.lt.i) then
               l = l+1
            else
               l = l+j
            end if
    5    continue
         wa(i) = wa(i)*rn
         ll = ll+i
   10 continue
      i = n
      if (i.eq.1) goto 75
!
!                                  ****  begin of the loop  ****
!
   15 im1 = i-1
      im2 = i-2
      ix = i*im1/2
      ixi = ix+i
!
!                                  calculate maximum off
!                                    diagonal element in row i
!
      aii = abs(a(ixi))
      save = zero
      do 20 l=1,im1
         temp = abs(a(ix+l))
         if (temp.gt.save) then
            save = temp
            j = l
         end if
   20 continue
      ichang = i
      if (aii.ge.alpha*save) goto 35
!
!                                  calculate maximum off
!                                    diagonal element in row j
!
      sigma = save
      jx = j*(j-1)/2
      jxj = jx+j
      jxt = jx+1
      ajj = abs(a(jxj))
      do 25 l=1,im1
         temp = abs(a(jxt))
         if (temp.gt.sigma.and.l.ne.j) sigma = temp
         if (l.lt.j) then
            jxt = jxt+1
         else
            jxt = jxt+l
         end if
   25 continue
!
!                                  choose a strategy for the
!                                    pivoting
!
      if (aii*sigma.ge.alpha*save*save) goto 35
!
      if (ajj.lt.alpha*sigma) goto 50
!
!                                  interchange rows i and j
!
      jxt = jx+1
      do 30 l=1,im1
         temp = a(ix+l)
         a(ix+l) = a(jxt)
         a(jxt) = temp
         if (l.lt.j) then
            jxt = jxt+1
         else
            jxt = jxt+l
         end if
   30 continue
      temp = a(jxj)
      a(jxj) = a(ixi)
      a(ixi) = a(ix+j)
      a(ix+j) = temp
      temp = wa(i)
      wa(i) = wa(j)
      wa(j) = temp
      aii = ajj
      ichang = j
!
!                                  we use a 1 by 1 pivot
!
   35 if (wa(i)+aii.le.wa(i)) ier = 65
      if (aii.eq.zero) goto 9005
      wa(i) = ichang
!
      aii = a(ixi)
      if (aii.lt.zero) wa(n+1) = wa(n+1)+1
      ixt = ix+1
      do 45 j=im1,1,-1
         save = -a(ix+j)/aii
         ixl = ixt-1
         ixt = ixt-j
         ish = ix-ixt+1
         mm = mod(j,5)
         if (mm.ne.0) then
            do 39 k=ixt,ixt+mm-1
               a(k) = a(k)+save*a(ish+k)
   39       continue
         end if
         ixf = ixt+mm
         do 40 k=ixf,ixl,5
            a(k) = a(k)+save*a(ish+k)
            a(k+1) = a(k+1)+save*a(ish+k+1)
            a(k+2) = a(k+2)+save*a(ish+k+2)
            a(k+3) = a(k+3)+save*a(ish+k+3)
            a(k+4) = a(k+4)+save*a(ish+k+4)
   40    continue
         a(ix+j) = save
   45 continue
      i = im1
      goto 75
!
!                                  we use a 2 by 2 pivot
!
   50 ix1 = ix-im1
      wa(n+1) = wa(n+1)+1
      if (j.eq.im1) goto 60
!
!                                  interchange rows i-1 and j
!
      jxt = jx+1
      do 55 l=1,im2
         temp = a(ix1+l)
         a(ix1+l) = a(jxt)
         a(jxt) = temp
         if (l.lt.j) then
            jxt = jxt+1
         else
            jxt = jxt+l
         end if
   55 continue
      temp = a(jxj)
      a(jxj) = a(ix)
      a(ix) = a(ix1+j)
      a(ix1+j) = temp
      temp = a(ix+j)
      a(ix+j) = a(ix+im1)
      a(ix+im1) = temp
      temp = wa(im1)
      wa(im1) = wa(j)
      wa(j) = temp
!
!                                  det must be negative
!
   60 det = a(ixi)*a(ix)-a(ixi-1)**2
!
      temp = max(wa(i),wa(im1))
      if (temp+abs(det).le.temp) ier = 65
      if (det.ge.zero) goto 9005
      wa(i) = j
      wa(im1) = det
!
      aim1i = a(ixi-1)/det
      aii = a(ixi)/det
      aim1 = a(ix)/det
      ixt = ix1
      do 70 j=im2,1,-1
         save = aim1i*a(ix1+j)-aim1*a(ix+j)
         temp = aim1i*a(ix+j)-aii*a(ix1+j)
         ixt = ixt-j
         do 65 k=1,j
            a(ixt+k) = a(ixt+k)+a(ix+k)*save+a(ix1+k)*temp
   65    continue
         a(ix+j) = save
         a(ix1+j) = temp
   70 continue
      i = im2
!
!                                  *** end of the loop ***
!
   75 if (i.gt.1) goto 15
      if (i.eq.1) then
         if (wa(1)+abs(a(1)).le.wa(1)) ier = 65
         if (a(1).eq.zero) goto 9005
         if (a(1).lt.zero) wa(n+1) = wa(n+1)+1
         wa(1) = 1
      end if
!
!   ****  second stage  ****       solve m*d*mt*x = b where
!                                    mt = m-transpose
!
   80 if (ijob.eq.1) go to 9000
!
      do 120 jc=1,m
!
!                                  solve m*d*y = b and store
!                                    y in b
!
         i = n
   85    if (i.le.1) goto 100
         im1 = i-1
         ix = i*im1/2
         ixi = ix+i
         ichang = wa(i)
         if (ichang.le.0) then
            write (*,'(2x,a)') 'error in routine leq1s |',              &
     &                         'array wa is wrong |'
            return
         end if
         save = b(ichang,jc)
         if (wa(im1).gt.zero) then
!
!                                  we use a 1 by 1 pivot
!
            b(ichang,jc) = b(i,jc)
            b(i,jc) = save/a(ixi)
            do 90 j=1,im1
               b(j,jc) = b(j,jc)+a(ix+j)*save
   90       continue
            i = im1
         else
!
!                                  we use a 2 by 2 pivot
!
            temp = b(i,jc)
            b(ichang,jc) = b(im1,jc)
            det = wa(im1)
            ix1 = ix-im1
            im2 = i-2
            b(i,jc) = (temp*a(ix)-save*a(ix+im1))/det
            b(im1,jc) = (save*a(ixi)-temp*a(ix+im1))/det
            do 95 j=1,im2
               b(j,jc) = b(j,jc)+a(ix+j)*temp+a(ix1+j)*save
   95       continue
            i = im2
         end if
         goto 85
  100    if (i.eq.1) then
            b(1,jc) = b(1,jc)/a(1)
            i = 2
         else
            i = 3
         end if
!
!                                  solve mt*x = y and store
!                                    x in b
!
  105    if (i.gt.n) goto 120
            ii = i
            if (wa(i).le.zero) ii = i+1
            im1 = i-1
            ix = i*im1/2
            do 115 k=i,ii
               save = b(k,jc)
               do 110 j=1,im1
                  save = save+a(ix+j)*b(j,jc)
  110          continue
               b(k,jc) = save
               ix = ix+k
  115       continue
            ichang = wa(ii)
            save = b(i,jc)
            b(i,jc) = b(ichang,jc)
            b(ichang,jc) = save
            i = ii+1
         goto 105
  120 continue
!
!                                  exit
!
 9000 if (ier.eq.0) return
      if (ier.eq.65) write (*,9065)
 9065 format(/5x,'warning error  ier=65  in  *** leq1s ***'/            &
     &       7x,'matrix a is algorithmically singular.'/)
      return
 9005 ier = 129
      write (*,9129)
 9129 format(/5x,'terminal error  ier=129  in  *** leq1s ***'/          &
     &       7x,'matrix a is exactly singular.'/)
      return
      end


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program triangle_area
!===============================================================================
! Calculate the area of a set of triangles on a sphere.

   use spherical_geometry, only: sg_triangle_area

   implicit none

   real(8) :: lon1, lat1, lon2, lat2, lon3, lat3, A
   real(8) :: r = 1._8  ! Default to unit sphere
   character(len=250) :: arg
   integer :: iostat

   call get_args

   iostat = 0
   do while (iostat == 0)
      read(*,*,iostat=iostat) lon1, lat1, lon2, lat2, lon3, lat3
      if (iostat < 0) exit
      if (iostat > 0) then
         write(0,'(a)') 'triangle_area: Error: Cannot read coordinates from stdin'
         stop
      endif
      A = sg_triangle_area(lon1, lat1, lon2, lat2, lon3, lat3, r=r, &
         degrees=.true., quiet=.true.)
      write(*,*) A
   enddo

contains
   subroutine usage
      write(0,'(a)') &
         'Usage: triangle_area (options) < (lon1 lat1 lon2 lat2 lon3 lat3 on stdin)', &
         'Coordinates are in degrees; output is in units of r.', &
         'By default, r is 1 (case for unit sphere)', &
         'Options:', &
         '   -r [radius] : Specify radius of sphere [1]'
      stop
   end subroutine usage

   subroutine get_args()
      integer :: iarg, narg
      narg = command_argument_count()
      iarg = 1
      do while (iarg <= narg)
         call get_command_argument(iarg, arg)
         select case(arg)
            case('-r')
               if (narg < iarg + 1) call usage
               call get_command_argument(iarg+1, arg)
               read(arg,*,iostat=iostat) r
               if (iostat /= 0) then
                  write(0,'(a)') 'triangle_area: Error: Can''t read radius from ' &
                     // 'argument "' // trim(arg) // '"'
                  stop 1
               endif
               iarg = iarg + 2
            case('-h')
               call usage
            case default
               call usage
         end select
      enddo
   end subroutine get_args

end program triangle_area
!-------------------------------------------------------------------------------


!--------------------------------------------------------------------!
!      This code is a part of GASS Reweighting codes                 !
! Fortran program to calculate the 4D probability distribution after !
! reweighting the metadynamics bias potentail in GASS sumulation     !
!--------------------------------------------------------------------!
!
PROGRAM prob_factor
IMPLICIT NONE
REAL*8 :: gridmin1, gridmax1, griddiff1, gridmin2, gridmax2, griddiff2
REAL*8 :: gridmin3, gridmax3, griddiff3, gridmin4, gridmax4, griddiff4
REAL*8 :: T0, T, ktb, bias_fact, alpha_cv, deltaT, den,kbT, kbT0
REAL*8 :: diff_s2, ds2, ss, hh, dum, num, alpha
REAL*8, ALLOCATABLE :: prob(:,:,:,:)
REAL*8, ALLOCATABLE :: cv1(:), cv2(:), vbias(:)
REAL*8, ALLOCATABLE :: cv3(:), cv4(:), ct(:)
INTEGER :: mtd_steps, md_steps, i, t_min, t_max, s1
INTEGER :: mtd_max, w_cv, w_hill, i_mtd, i_md, s2, s3, s4
INTEGER :: i_s1, i_s2, i_s3, i_s4, nbin1, nbin2, nbin3, nbin4
INTEGER :: index1, index2, index3, index4

REAL*8, PARAMETER :: kb=1.9872041E-3 !kcal K-1 mol-1
REAL*8, PARAMETER :: kj_to_kcal = 0.239006

OPEN(1,FILE='input',STATUS='old')
!OPEN(2,FILE='PROB_4D.dat',STATUS='replace',form='unformatted')
OPEN(2,FILE='PROB_4D',STATUS='replace')
OPEN(11,FILE='COLVAR',STATUS='old')
OPEN(12,FILE='HILLS',STATUS='old')
OPEN(21,file='data_ct.dat',status='old')
OPEN(22,file='data_vbias.dat',status='old')

CALL get_steps(11,md_steps)
CALL get_steps(12,mtd_steps)

!print *, 'md_steps=', md_steps, 'mtd_steps=', mtd_steps

read(1,*) T, T, bias_fact
read(1,*) t_min, t_max

IF(t_max.gt.md_steps)STOP '!!ERROR: t_max > total MD steps'

read(1,*) gridmin1, gridmax1, griddiff1
read(1,*) gridmin2, gridmax2, griddiff2
read(1,*) gridmin3, gridmax3, griddiff3
read(1,*) gridmin4, gridmax4, griddiff4
read(1,*) w_cv, w_hill

 deltaT = (bias_fact - 1.d0)*T
 alpha  = (T + deltaT)/deltaT

 kbT = kb*T
 ktb = kbT*bias_fact

WRITE(*,'(A,I10)')'No: of MTD steps        =',mtd_steps
WRITE(*,'(A,I10)')'No: of MD  steps        =',md_steps
WRITE(*,'(A,F9.2)')'Physical Temp (K)      =',T
WRITE(*,'(A,F9.2)')'CV Temp (K)            =',T
WRITE(*,'(A,F9.2)')'Bias Factor (K)        =',bias_fact
WRITE(*,'(A,I10)')'Print Freq. cvmdck_mtd  =',w_cv
WRITE(*,'(A,I10)')'Freq. of Hill Update    =',w_hill
WRITE(*,'(A,I10)')'Reweigtht: Min step     =',t_min
WRITE(*,'(A,I10)')'Reweigtht: Max step     =',t_max
WRITE(*,'(A,F9.2)')'DeltaT      (K)        =',deltaT
WRITE(*,'(A,F9.2)')'Alpha value            =',alpha

ALLOCATE(cv1(md_steps),cv2(md_steps))
ALLOCATE(cv3(md_steps),cv4(md_steps))
ALLOCATE(vbias(md_steps),ct(mtd_steps))

DO i_md=1,md_steps
 READ(11,*) dum,cv1(i_md),cv2(i_md),cv3(i_md),cv4(i_md)
     IF( cv1(i_md) .gt.  3.14d0)  cv1(i_md) = cv1(i_md) - 6.28d0
     IF( cv1(i_md) .lt. -3.14d0 ) cv1(i_md) = cv1(i_md) + 6.28d0
     IF( cv2(i_md) .gt.  3.14d0)  cv2(i_md) = cv2(i_md) - 6.28d0
     IF( cv2(i_md) .lt. -3.14d0 ) cv2(i_md) = cv2(i_md) + 6.28d0
     IF( cv3(i_md) .gt.  3.14d0)  cv3(i_md) = cv3(i_md) - 6.28d0
     IF( cv3(i_md) .lt. -3.14d0 ) cv3(i_md) = cv3(i_md) + 6.28d0
     IF( cv4(i_md) .gt.  3.14d0)  cv4(i_md) = cv4(i_md) - 6.28d0
     IF( cv4(i_md) .lt. -3.14d0 ) cv4(i_md) = cv4(i_md) + 6.28d0
END DO

nbin1 = NINT((gridmax1-gridmin1)/griddiff1)+1
nbin2 = NINT((gridmax2-gridmin2)/griddiff2)+1
nbin3 = NINT((gridmax3-gridmin3)/griddiff3)+1
nbin4 = NINT((gridmax4-gridmin4)/griddiff4)+1

write(*,*) nbin1, nbin2, nbin3, nbin4

write(*,*) "reading vbias.dat file"

do i_md=1,md_steps
  read(22,*) dum, vbias(i_md)
end do

write(*,*) "reading ct.dat file"
do i_mtd=1,mtd_steps
  read(21,*) dum, ct(i_mtd)
end do

ALLOCATE(prob(nbin1,nbin2,nbin3,nbin4))

WRITE(*,*) 'calculating  probability'

den=0.d0
prob=0.d0

DO i_md=1,md_steps
 IF((i_md.GT.t_min).AND.(i_md.LT.t_max))THEN
 index1 = nint((cv1(i_md)-gridmin1)/griddiff1) +1
 index2 = nint((cv2(i_md)-gridmin2)/griddiff2) +1
 index3 = nint((cv3(i_md)-gridmin3)/griddiff3) +1
 index4 = nint((cv4(i_md)-gridmin4)/griddiff4) +1

     IF(index1.gt.0.and.index2.gt.0.and.index3.gt.0.and.index4.gt.0.and.index1.le.&
        nbin1.and.index2.le.nbin2.and.index3.le.nbin3.and.index4.le.nbin4) then

      i_mtd=(i_md*w_cv/w_hill)

      IF(i_mtd == 0) THEN
        dum=0.d0
      ELSE
        dum=vbias(i_md) - ct(i_mtd)
      ENDIF

      prob(index1,index2,index3,index4) = prob(index1,index2,index3,index4) + DEXP(dum/kbT)
      den=den+DEXP(dum/kbT)
     END IF

 END IF
END DO

  dum=den*griddiff1*griddiff2*griddiff3*griddiff4
  den=1.d0/dum

DO i_s1=1,nbin1
s1=DFLOAT(i_s1-1)*griddiff1+gridmin1
   DO i_s2=1,nbin2
   s2=DFLOAT(i_s2-1)*griddiff2+gridmin2
      DO i_s3=1,nbin3
      s3=DFLOAT(i_s3-1)*griddiff3+gridmin3
         DO i_s4=1,nbin4
         s4=DFLOAT(i_s4-1)*griddiff4+gridmin4

           prob(i_s1,i_s2,i_s3,i_s4)=prob(i_s1,i_s2,i_s3,i_s4)*den

           WRITE(2,'(E16.8)')prob(i_s1,i_s2,i_s3,i_s4)
         END DO
      END DO
   END DO
END DO
 WRITE(*,'(A)')'Unbiased distribution written in PROB_4D.dat'

close(1)
close(2)
close(11)
close(12)
close(21)
close(22)

DEALLOCATE(cv1, cv2, vbias, ct)
DEALLOCATE(cv3, cv4)
DEALLOCATE(prob)

END PROGRAM

SUBROUTINE get_steps(iunit,nsteps)
IMPLICIT NONE
INTEGER :: iunit, nsteps
INTEGER :: ios
nsteps=0
REWIND(iunit)
  Read_Loop: DO
  READ(iunit,*,IOSTAT=ios)
    IF(ios.ne.0)EXIT Read_Loop
    nsteps=nsteps+1
  END DO Read_Loop
REWIND(iunit)
END SUBROUTINE
!------------------------------------------------------------------------------------!
!


!-----------------------------------------------------------------------
!    Author:       Ran Chu
!    Date:         11/28/2019
!-----------------------------------------------------------------------

MODULE pair_module

USE kind_module
USE numerical_module, ONLY : zero
USE physcnst_module, ONLY: Gw, mp, hbar, cvel, pi

!-----------------------------------------------------------------------
! nnud     : upper limit to the neutrino flavor extent
! cpair1   : neutrino flavor coeeficient for computing pair rates
! cpair2   : neutrino flavor coeeficient for computing pair rates
!-----------------------------------------------------------------------

INTEGER, PARAMETER                                         :: nnud=4

REAL(KIND=double), DIMENSION(nnud)                         :: cpair1
REAL(KIND=double), DIMENSION(nnud)                         :: cpair2

!-----------------------------------------------------------------------
!   Gauss-Legendre parameters for Pairs
!-----------------------------------------------------------------------
! nleg     : number of points of Gauss-Lagendre quadrature
! xe       : points of Gauss-Lagendre quadrature
! wte      : weights of Gauss-Lagendre quadrature
!-----------------------------------------------------------------------

INTEGER, PARAMETER                                         :: nleg = 24

REAL(KIND=double), DIMENSION(nleg)                         :: xe
REAL(KIND=double), DIMENSION(nleg)                         :: wte

!-----------------------------------------------------------------------
!   Constants for paircal
!-----------------------------------------------------------------------
! g2       : combination of physical constants
! coef     : combination of physical constants
!-----------------------------------------------------------------------

REAL(KIND=double)    :: g2 = ( Gw/mp**2 )**2 * hbar**2 * cvel**3 ! cm3/MeV2 s
REAL(KIND=double)    :: coef = 2.d0 * pi * ( 1.d0/cvel ) * ( 1.d0/( 2.d0 * pi * hbar * cvel ) )**3 &
                               * ( Gw/mp**2 )**2 * hbar**2 * cvel**3 / pi

END module pair_module


  subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk, &
             dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
  use array_lib
  use math_lib
  implicit none

! Purpose:
!   Create a discrete drop size distribution
!
!   Starting with Quickbeam V3, this routine now allows input of
!   both effective radius (Re) and total number concentration (Nt)
!   Roj Marchand July 2010
!
!   The version in Quickbeam v.104 was modified to allow Re but not Nt
!   This is a significantly modified form for the version
!
!   Originally Part of QuickBeam v1.03 by John Haynes
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:
!
!   [Q]        hydrometeor mixing ratio (g/kg)
!   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
!
!   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
!   [nsizes]   number of elements of [D]
!
!   [dtype]    distribution type
!   [rho_a]    ambient air density (kg m^-3)
!   [tk]       temperature (K)
!   [dmin]     minimum size cutoff (um)
!   [dmax]     maximum size cutoff (um)
!   [rho_c]    alternate constant density (kg m^-3)
!   [p1],[p2],[p3]  distribution parameters
!
! Input/Output:
!   [apm]      a parameter for mass (kg m^[-bpm])
!   [bmp]      b params for mass
!
! Outputs:
!   [N]        discrete concentrations (cm^-3 um^-1)
!              or, for monodisperse, a constant (1/cm^3)
!
! Requires:
!   function infind
!
! Created:
!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   01/31/06  Port from IDL to Fortran 90
!   07/07/06  Rewritten for variable DSD's
!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
!   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).

! ----- INPUTS -----

  integer, intent(in) :: nsizes
  integer, intent(in) :: dtype
  real*8, intent(in)  :: Q,Re,Np,D(nsizes)
  real*8, intent(in)  :: rho_a,tk,dmin,dmax,rho_c,p1,p2,p3

  real*8, intent(inout) :: apm,bpm

! ----- OUTPUTS -----

  real*8, intent(out) :: N(nsizes)

! ----- INTERNAL -----

   real*8 :: fc(nsizes)

  real*8 :: &
  N0,D0,vu,local_np,dm,ld, &            ! gamma, exponential variables
  dmin_mm,dmax_mm,ahp,bhp, &        ! power law variables
  rg,log_sigma_g, &         ! lognormal variables
  rho_e                 ! particle density (kg m^-3)

  real*8 :: tmp1, tmp2
  real*8 :: pi,rc,tc

  integer k,lidx,uidx

  tc = tk - 273.15
  pi = acos(-1.0)

  ! // if density is constant, store equivalent values for apm and bpm
  if ((rho_c > 0) .and. (apm < 0)) then
    apm = (pi/6)*rho_c
    bpm = 3.
  endif

  ! will preferentially use Re input over Np.
  ! if only Np given then calculate Re
  ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
  if(Re==0 .and. Np>0) then

        call calc_Re(Q,Np,rho_a, &
             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
             Re)
  endif

  select case(dtype)

! ---------------------------------------------------------!
! // modified gamma                                        !
! ---------------------------------------------------------!
! :: np = total number concentration
! :: D0 = characteristic diameter (um)
! :: dm = mean diameter (um) - first moment over zeroth moment
! :: vu = distribution width parameter

  case(1)

    if( abs(p3+2) < 1E-8) then

    if( Np>1E-30) then

        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2.0 ! units of Nt = Np*rhoa = #/cm^3
    else
        print *, 'Error: Must specify a value for Np in each volume', &
             ' with Morrison/Martin Scheme.'
            stop
    endif

    elseif (abs(p3+1) > 1E-8) then

      ! vu is fixed in hp structure
      vu = p3

    else

      ! vu isn't specified

      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
      stop

    endif

      if(Re>0) then

    D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)

        fc = ( &
             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
         ) * 1E-12

        N = fc*rho_a*(Q*1E-3)

      elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter

        dm = p2
    D0 = gamma(vu)/gamma(vu+1)*dm

        fc = ( &
             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
         ) * 1E-12

        N = fc*rho_a*(Q*1E-3)

      elseif(abs(p3+1) > 1E-8)  then! use default number concentration

        local_np = p1 ! total number concentration / pa check

    tmp1 = (Q*1E-3)**(1./bpm)

        fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))** &
             (1./bpm))**vu

        N = ( &
          (rho_a*local_np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
          exp(-1.*fc**(1./vu)/tmp1) &
      ) * 1E-12

      else

        print *, 'Error:  No default value for Dm or Np provided!  '
        stop

      endif

! ---------------------------------------------------------!
! // exponential                                           !
! ---------------------------------------------------------!
! :: N0 = intercept parameter (m^-4)
! :: ld = slope parameter (um)

  case(2)

    if(Re>0) then

        ld = 1.5/Re   ! units 1/um

    fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
               exp(-1.*(ld*1E6)*(D*1E-6))*1E-12

        N = fc*rho_a*(Q*1E-3)

    elseif (abs(p1+1) > 1E-8) then

    ! use N0 default value

        N0 = p1

        tmp1 = 1./(1.+bpm)

        fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)

        N = ( &
            N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
    ) * 1E-12

    elseif (abs(p2+1) > 1E-8) then

    !     used default value for lambda
        ld = p2

        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12

        N = fc*rho_a*(Q*1E-3)

    else

      !  ld "parameterized" from temperature (carry over from original Quickbeam).
      ld = 1220*10.**(-0.0245*tc)*1E-6
      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))

      N = ( &
          N0*exp(-1*ld*D) &
          ) * 1E-12

    endif

! ---------------------------------------------------------!
! // power law                                             !
! ---------------------------------------------------------!
! :: ahp = Ar parameter (m^-4 mm^-bhp)
! :: bhp = br parameter
! :: dmin_mm = lower bound (mm)
! :: dmax_mm = upper bound (mm)

  case(3)

    if(Re>0) then
        print *, 'Variable Re not supported for ', &
         'Power-Law distribution'
    stop
    elseif(Np>0) then
        print *, 'Variable Np not supported for ', &
         'Power-Law distribution'
    stop
    endif

!   :: br parameter
    if (abs(p1+2) < 1E-8) then
!     :: if p1=-2, bhp is parameterized according to Ryan (2000),
!     :: applicatable to cirrus clouds
      if (tc < -30) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -30) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif
    elseif (abs(p1+3) < 1E-8) then
!     :: if p1=-3, bhp is parameterized according to Ryan (2000),
!     :: applicable to frontal clouds
      if (tc < -35) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -35) .and. (tc < -17.5)) then
        bhp = -2.65+0.09*((tc+273)-255.66)
      elseif ((tc >= -17.5) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif
    else
!     :: otherwise the specified value is used
      bhp = p1
    endif

!   :: Ar parameter
    dmin_mm = dmin*1E-3
    dmax_mm = dmax*1E-3

!   :: commented lines are original method with constant density
      ! rc = 500.       ! (kg/m^3)
      ! tmp1 = 6*rho_a*(bhp+4)
      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
      ! ahp = (Q*1E-3)*1E12*tmp1/tmp2

!   :: new method is more consistent with the rest of the distributions
!   :: and allows density to vary with particle size
      tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
      tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
      ahp = tmp1/tmp2 * 1E24
      ! ahp = tmp1/tmp2

      lidx = infind(D,dmin)
      uidx = infind(D,dmax)
      do k=lidx,uidx

        N(k) = ( &
        ahp*(D(k)*1E-3)**bhp &
    ) * 1E-12

      enddo

    ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm

! ---------------------------------------------------------!
! // monodisperse                                          !
! ---------------------------------------------------------!
! :: D0 = particle diameter (um)

  case(4)

    if (Re>0) then
        D0 = Re
    else
        D0 = p1
    endif

      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
      fc(1) = (6./(pi*D0**3*rho_e))*1E12
      N(1) = fc(1)*rho_a*(Q*1E-3)

! ---------------------------------------------------------!
! // lognormal                                             !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: rg = mean radius (um)
! :: log_sigma_g = ln(geometric standard deviation)

  case(5)
    if (abs(p1+1) < 1E-8 .or. Re>0 ) then

!     // rg, log_sigma_g are given
      log_sigma_g = p3
      tmp2 = (bpm*log_sigma_g)**2.
      if(Re.le.0) then
        rg = p2
      else
    rg =Re*exp(-2.5*(log_sigma_g**2))
      endif

         fc = 0.5 * ( &
         (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
         log_sigma_g*D*0.5*1E-6)) * &
         exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
         ) * 1E-12

      N = fc*rho_a*(Q*1E-3)

    elseif (abs(p2+1) < 1E-8 .or. Np>0) then

!     // Np, log_sigma_g are given
      if(Np>0) then
        local_Np=Np
      else
        local_Np = p1
      endif

      log_sigma_g = p3
      N0 = local_np*rho_a
      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.
      rg = ((tmp1/tmp2)**(1/bpm))*1E6

      N = 0.5*( &
        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
    exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
    ) * 1E-12

    else

      print *, 'Error: Must specify a value for sigma_g'
      stop

    endif

  end select

  end subroutine dsd


*> \brief \b DPPTRI
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DPPTRI + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   AP( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DPPTRI computes the inverse of a real symmetric positive definite
*> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
*> computed by DPPTRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangular factor is stored in AP;
*>          = 'L':  Lower triangular factor is stored in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
*>          On entry, the triangular factor U or L from the Cholesky
*>          factorization A = U**T*U or A = L*L**T, packed columnwise as
*>          a linear array.  The j-th column of U or L is stored in the
*>          array AP as follows:
*>          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
*>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*>
*>          On exit, the upper or lower triangle of the (symmetric)
*>          inverse of A, overwriting the input factor U or L.
*> \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 (i,i) element of the factor U or L is
*>                zero, and the inverse could not be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup doubleOTHERcomputational
*
*  =====================================================================
      SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JC, JJ, JJN
      DOUBLE PRECISION   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRI', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Invert the triangular Cholesky factor U or L.
*
      CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Compute the product inv(U) * inv(U)**T.
*
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
            IF( J.GT.1 )
     $         CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
            AJJ = AP( JJ )
            CALL DSCAL( J, AJJ, AP( JC ), 1 )
   10    CONTINUE
*
      ELSE
*
*        Compute the product inv(L)**T * inv(L).
*
         JJ = 1
         DO 20 J = 1, N
            JJN = JJ + N - J + 1
            AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
            IF( J.LT.N )
     $         CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
     $                     AP( JJN ), AP( JJ+1 ), 1 )
            JJ = JJN
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of DPPTRI
*
      END


      double precision function psi(xp,yp,zp,t)
      implicit none

      double precision xp,yp,zp,t
      double precision r2, pi2, revs_per_s

      double precision pi
      common /compi/ pi

      revs_per_s = 0.5d0

      pi2 = 2*pi

      psi = pi2*revs_per_s*zp

      psi = -psi

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end


      subroutine rtpss(nndim,ndata,nefn,w,efn,theta,ierr,work)
c
c  computes discrete prolate spheroidal sequences using the symmetric
c  tridiagonal form given in d.slepian, bell syst. tech. j. 57 (1978),
c  p. 1376, equation 14. there is a further reduction into even and
c  odd symmetric functions to minimize the size of the eigenvalue
c  problem, see eispack sections 2.1.17 and 2.2.8.
c  adapted by a.d. chave, lanl, jan 1986 from code written by
c  d.j. thomson, at&t bell labs.
c  argument list:
c    nndim-leading dimension of efn
c    ndata-number of data points (e.g., time) to return in efn,
c          this corresponds to n in slepian
c    nefn-number of dpss to compute, lowest order ones are returned
c         first
c    w-the bandwidth (=time-bandwidth product/ndata)
c    efn-array to contain the dpss, first dimension corresponds to
c        time and second to the order of the sequence
c    theta-vector of length nefn containing the differential eigenvalues
c    ierr-error flag, 0 for normal return, 1 for error in tridib,
c         2 for error in tinvit
c    work-work space of dimension at least 9*ndata/2+3*nefn/2+
c         ndata*nefn/4+11
c
c  calls rtpss1
c
      implicit double precision (a-h,o-z)
      dimension efn(nndim,nefn),theta(nefn),work(1)
      logical flag
      parameter (pi=3.141592653589793d0)
      ndim   = nndim
      tw     = 2.*w
      ctpw   = cos(pi*tw)
      nodefn = nefn/2
      nevefn = nefn - nodefn
      m      = ndata/2
      mdim   = ndata - m
c  allocate storage in work
      lefnh  = 1
      levh   = mdim*nevefn + lefnh
      lfv1   = nevefn + levh
      lfv2   = mdim + lfv1
      lfv3   = mdim + lfv2
      lw     = mdim + lfv3

c  compute even eigenfunctions
      sym=1.
      flag=.false.
      call rtpss1(efn,ndim,ndata,mdim,mdim,nevefn,ctpw,theta,flag,
     $             sym,work(lefnh),work(levh),work(lfv1),work(lfv2),
     $             work(lfv3),ierr,work(lw))
c  compute odd eigenfunctions
      sym=-1.
      flag=m.ne.mdim
      if(nodefn.gt.0)call rtpss1(efn(1,2),ndim,ndata,m,mdim,nodefn,
     $                            ctpw,theta(2),flag,sym,work(lefnh),
     $                            work(levh),work(lfv1),work(lfv2),
     $                            work(lfv3),ierr,work(lw))
      return
      end

c $Id$