program infortran

    use config
    use input
    use param
    use hamiltonian
    use surface
    use device
    use velocity_mat
    use write_data
    use circular
    use util

    implicit none

    include "mpif.h"

    integer(kind=4) :: ll, ie, i, ik, j, k, l, nb, m
    real(kind=8) :: kcry(3),b_sc(3,3),ktp(3)
    complex(kind=8),allocatable :: Ham(:,:,:), eigvec(:,:,:)
    complex(kind=8),allocatable :: Px_L(:,:,:), Py_L(:,:,:)
    complex(kind=8),allocatable :: Px_R(:,:,:), Py_R(:,:,:)
    complex(kind=8),allocatable :: gl_adv(:,:,:), gr_ret(:,:,:)
    complex(kind=8),allocatable :: gl_plus(:,:,:), gr_minus(:,:,:)
    complex(kind=8),allocatable :: gml_adv(:,:,:), gmr_ret(:,:,:)
    complex(kind=8),allocatable :: sl_adv(:,:,:), sr_ret(:,:,:)
    complex(kind=8),allocatable :: G_D_RL(:,:,:),G_D_LR(:,:,:)
    complex(kind=8),allocatable :: G_L(:,:,:),G_R(:,:,:)
    complex(kind=8),allocatable :: tlr(:,:,:,:),trl(:,:,:,:)
    real(kind=8),allocatable :: transl(:,:),transr(:,:)
    real(kind=8),allocatable :: transl_s(:,:),transr_s(:,:)
    real(kind=8),allocatable :: transl_ns(:,:),transr_ns(:,:)
    real(kind=8),allocatable :: transl_reduce(:,:),transr_reduce(:,:)
    real(kind=8),allocatable :: transl_s_reduce(:,:),transr_s_reduce(:,:)
    real(kind=8),allocatable :: transl_ns_reduce(:,:),transr_ns_reduce(:,:)
    real(kind=8),allocatable :: refll_s(:,:),reflr_s(:,:)
    real(kind=8),allocatable :: refll_ns(:,:),reflr_ns(:,:)
    real(kind=8),allocatable :: refll_ns_reduce(:,:),reflr_ns_reduce(:,:)
    real(kind=8),allocatable :: refll_s_reduce(:,:),reflr_s_reduce(:,:)
    real(kind=8),allocatable :: surface_dos_l(:,:),surface_dos_r(:,:)
    real(kind=8),allocatable :: surface_dos_l_reduce(:,:),surface_dos_r_reduce(:,:)
    real(kind=8),allocatable :: device_dos_reduce(:,:),device_dos(:,:)
    real(kind=8),allocatable :: ldos(:,:,:,:)
    real(kind=8),allocatable :: eig(:,:)
    complex(kind=8),allocatable :: eigv_pc(:,:)
    complex(kind=8),allocatable :: Ham_f(:,:,:)
    complex(kind=8),allocatable :: Ham_uc_l(:,:),Ham_uc_r(:,:)
    real(kind=8),allocatable    :: eig_uc_l(:),eig_uc_r(:)
    complex(kind=8),allocatable :: evs_uc_l(:,:),evs_uc_r(:,:)
    complex(kind=8),allocatable :: Ham_pc_l(:,:),Ham_pc_r(:,:)
    real(kind=8),allocatable    :: eig_pc_l(:),eig_pc_r(:)
    complex(kind=8),allocatable :: evs_pc_l(:,:),evs_pc_r(:,:)
    ! slab calculation for surface band structure
    complex(kind=8),allocatable :: Ham_slab_l(:,:),Ham_slab_r(:,:)
    real(kind=8),allocatable    :: eig_slab_l(:),eig_slab_r(:)
    complex(kind=8),allocatable :: evs_slab_l(:,:),evs_slab_r(:,:)
    real(kind=8),allocatable ::  pos_slab_l(:,:),pos_slab_r(:,:)
    real(kind=8) ::  latvec_slab(3,3),recvec_slab(3,3)
    integer(kind=4) :: natoms_slab_l,natoms_slab_r
    integer(kind=4) :: norb_slab_l,norb_slab_r
    integer(kind=4),allocatable :: atom_orb_num_slab_l(:)
    integer(kind=4),allocatable :: atom_orb_num_slab_r(:)
    integer(kind=4)             :: norb ! total number of orbitals
    integer(kind=4) :: norb_pc_l, norb_uc_l, norb_pc_r, norb_uc_r
    integer(kind=4) :: temp_count,ntemp
    real(kind=8) :: p_crys_temp(2)
    ! search k point for misorientation unit cell
    real(kind=8),allocatable :: k_misori(:,:)
    integer(kind=4) :: n_k_misori
    real(kind=8) :: k_mis_temp(3),dk_mis_temp(3)
    real(kind=8),allocatable :: kuc_misori(:,:)

    call MPI_INIT(ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr)

    call load_configure()
    call load_input()
    call k_grid_in_ws()
    call load_param()

    ! obtain the size of Hamiltonian
    norb = sum(atom_orb_num) ! norb can be known only after loading params
    norb_pc_l = sum(atom_orb_num_pc_l)
    norb_pc_r = sum(atom_orb_num_pc_r)
    norb_uc_l = sum(atom_orb_num_uc_l)
    norb_uc_r = sum(atom_orb_num_uc_r)

    allocate(pos_orb_pc_l(norb_pc_l,4))
    allocate(pos_orb_uc_l(norb_uc_l,4))
    allocate(pos_orb_pc_r(norb_pc_r,4))
    allocate(pos_orb_uc_r(norb_uc_r,4))

    ! get the dimensions for Hamiltonian
    ! of primitive cell
    call get_pos_orb(norb_pc_l,norb_uc_l,&
                     norb_pc_r,norb_uc_r)

    ! calculate the eigenvales on k points
    ! along k path
    if (path_mode.eq.1)then
        if (side(1:1) .eq. 'l') then
            if (allocated(Egrid)) deallocate(Egrid)
            allocate(Egrid(norb_pc_l,n_kpath_points),&
                 eigv_pc(norb_pc_l,norb_pc_l))
            ne = norb_pc_l ! here, we overwrite ne
            nk = n_kpath_points ! and nk
            nkcore = nk/numprocs
            Egrid = 0.0d0
            eigv_pc = 0.0d0
            nb = max(n_bloch_x,n_bloch_y)
            deallocate(k_grid)
            allocate(k_grid(nk,3))
            k_grid = 100.0
            b_sc = recivec
            b_sc(3,3) = 2*pi/az1
            do i = 1,n_kpath_points
                !call gen_ham_pc_l(norb_pc_l,&
                !matmul(kpath_points(i,:),recivec_pc_l),&
                !Egrid(:,i),eigv_pc)
                do j = -nb,nb
                    do k = -nb,nb
                        do l = -nb,nb
                            ktp = matmul(kpath_points(i,:),&
                            recivec_pc_l)+&
                            matmul((/dble(j),dble(k),dble(l)/),&
                            b_sc)
                            kcry = matmul(ktp,inv_real(b_sc))
                            !write(*,*) kpath_points(i,:)
                            if (abs(kcry(1).lt.0.5).and.&
                                abs(kcry(2).lt.0.5).and.&
                                abs(kcry(3).lt.0.5)) then
                                k_grid(i,:) = ktp
                            end if
                        end do
                    end do
                end do
               ! write(*,*)'uc', Egrid(:,1)
            end do
        end if
    end if

    allocate(Ham(numprocs,norb,norb))
    allocate(eigvec(numprocs,norb,norb))
    allocate(eig(numprocs,norb))

    Ham = 0.0d0
    eigvec = 0.0d0
    eig = 0.0d0

    ! i th k point on a core
    call gen_ham_mpi(1,1,Ham,eigvec,eig,norb)

    call get_periodic_lead_orb_num()

    if (path_mode.eq.1)then
        ! calculate the uc band
!        allocate(Ham_uc_l(norb_uc_l,norb_uc_l),&
!                 eig_uc_l(norb_uc_l),&
!                 evs_uc_l(norb_uc_l,norb_uc_l))
!        allocate(Ham_uc_r(norb_uc_r,norb_uc_r),&
!                 eig_uc_r(norb_uc_r),&
!                 evs_uc_r(norb_uc_r,norb_uc_r))

!        do i = 1,n_kpath_points
!            call gen_ham_uc_l(norb_uc_l,&
!                           matmul(kpath_points(i,:),&
!                           reci_uc_l),Ham_uc_l,&
!                           eig_uc_l,evs_uc_l)
!            call write_eig('eigenl',eig_uc_l)
!            call gen_ham_uc_r(norb_uc_r,&
!                           matmul(kpath_points(i,:),&
!                           reci_uc_r),Ham_uc_r,&
!                           eig_uc_r,evs_uc_r)
!            call write_eig('eigenr',eig_uc_r)
!        end do
        ! the unit cell for misorientation
        uc_misori = 2*pi*transpose(inv_real(uc_misori))
        allocate(k_misori((2*n_uc_misori1+1)*(2*n_uc_misori2+1)*(2*n_uc_misori2+1),3))
        allocate(kuc_misori(size(kpath_points,1),3))
        kuc_misori = 0.0d0
        ! Calculate the pc band
        allocate(Ham_pc_l(norb_pc_l,norb_pc_l),&
                 eig_pc_l(norb_pc_l),&
                 evs_pc_l(norb_pc_l,norb_pc_l))
        allocate(Ham_pc_r(norb_pc_r,norb_pc_r),&
                 eig_pc_r(norb_pc_r),&
                 evs_pc_r(norb_pc_r,norb_pc_r))

        do i = 1,n_kpath_points
            k_misori = 0.0d0
            n_k_misori = 0
            k_mis_temp(:) = matmul(kpath_points(i,:),&
                                recivec_pc_l)
            do j = -n_uc_misori1,n_uc_misori1
                do k = -n_uc_misori2,n_uc_misori2
                    do l = -n_uc_misori3,n_uc_misori3
                        dk_mis_temp(:) = matmul((/dble(j),dble(k),dble(l)/),&
                                         uc_misori)
                        if (in_ws(uc_misori,k_mis_temp+dk_mis_temp)>0) then
                            n_k_misori = n_k_misori + 1
                            k_misori(n_k_misori,:) = k_mis_temp+dk_mis_temp
                        end if
                    end do
                end do
            end do
            kuc_misori(i,:) = find_min_dist(k_misori(1:n_k_misori,:),n_k_misori)
            call gen_ham_pc_l(norb_pc_l,&
                           matmul(kpath_points(i,:),&
                           recivec_pc_l),Ham_pc_l)
            call eigenH(Ham_pc_l,eig_pc_l,evs_pc_l)
            call write_eig('eigenl',eig_pc_l)
            call gen_ham_pc_r(norb_pc_r,&
                           matmul(kpath_points(i,:),&
                           recivec_pc_r),Ham_pc_r)
            call eigenH(Ham_pc_r,eig_pc_r,evs_pc_r)
            call write_eig('eigenr',eig_pc_r)
        end do
        open(unit=15, file=trim(adjustl(output_dir))//"/kuc_misori.dat",status="REPLACE",action="write")
        m = size(kuc_misori,1)
        write(15,*) m
        do i = 1,m
             WRITE(15,1015) kuc_misori(i,:)
             1015 format(3f20.10)
        end do
        close(unit=15)
        stop
    end if

    if (path_mode .eq. 4)  then
        latvec_slab = 0.0d0
        recvec_slab = 0.0d0
        latvec_slab(1:2,1:2) = latvec(1:2,1:2)
        latvec_slab(3,3) = latvec(3,3)*5 ! large vaccuum
        recvec_slab = 2.0d0* pi * transpose(inv_real(latvec_slab))
        natoms_slab_l = 2*period_left+buffer_left
        natoms_slab_r = 2*period_right+buffer_right
        norb_slab_l = norb_uc_l/period_left*natoms_slab_l
        norb_slab_r = norb_uc_r/period_right*natoms_slab_r
        allocate(Ham_slab_l(norb_slab_l,norb_slab_l),&
                 eig_slab_l(norb_slab_l),&
                 evs_slab_l(norb_slab_l,norb_slab_l),&
                 pos_slab_l(natoms_slab_l,4),&
                 atom_orb_num_slab_l(natoms_slab_l))
        allocate(Ham_slab_r(norb_slab_r,norb_slab_r),&
                 eig_slab_r(norb_slab_r),&
                 evs_slab_r(norb_slab_r,norb_slab_r),&
                 pos_slab_r(natoms_slab_r,4),&
                 atom_orb_num_slab_r(natoms_slab_r))
        pos_slab_l = 0.0d0
        pos_slab_l(1:natoms_slab_l,:) = positions(1:natoms_slab_l,:)
        atom_orb_num_slab_l = atom_orb_num(1:natoms_slab_l)
        pos_slab_r = 0.0d0
        pos_slab_r(1:natoms_slab_r,:) = positions(natoms-natoms_slab_r+1:natoms,:)
        atom_orb_num_slab_r = atom_orb_num(natoms-natoms_slab_r+1:natoms)
        do i = 1,n_kpath_points
            call gen_ham_slab(norb_slab_l,&
                          matmul(kpath_points(i,:),recvec_slab),&
                          Ham_slab_l,&
                          eig_slab_l,evs_slab_l,pos_slab_l,&
                          latvec_slab,atom_orb_num_slab_l)
            call gen_ham_slab(norb_slab_r,&
                          matmul(kpath_points(i,:),recvec_slab),&
                          Ham_slab_r,&
                          eig_slab_r,evs_slab_r,pos_slab_r,&
                          latvec_slab,atom_orb_num_slab_r)
            call write_eig('slabl',eig_slab_l)
            call write_eig('slabr',eig_slab_r)
        end do
        stop
    end if

    if (path_mode.eq.5) then
        ! calculate the uc band
        allocate(Ham_uc_l(norb_uc_l,norb_uc_l),&
                 eig_uc_l(norb_uc_l),&
                 evs_uc_l(norb_uc_l,norb_uc_l))
        allocate(Ham_uc_r(norb_uc_r,norb_uc_r),&
                 eig_uc_r(norb_uc_r),&
                 evs_uc_r(norb_uc_r,norb_uc_r))

        ntemp = 100

        do i = 1,n_kpath_points
            do j = -ntemp, ntemp
                call gen_ham_uc_l(norb_uc_l,&
                           matmul(kpath_points(i,:)&
                           +(/0.0d0,0.0d0,dble(j)/dble(ntemp)/),&
                           reci_uc_l),Ham_uc_l,&
                           eig_uc_l,evs_uc_l)
                call write_eig('eigen_uc_l',eig_uc_l)
                call gen_ham_uc_r(norb_uc_r,&
                           matmul(kpath_points(i,:)&
                           +(/0.0d0,0.0d0,dble(j)/dble(ntemp)/),&
                           reci_uc_r),Ham_uc_r,&
                           eig_uc_r,evs_uc_r)
                call write_eig('eigen_uc_r',eig_uc_r)
            end do
        end do
        stop
    end if

    allocate(gl_adv(numprocs,nl,nl))
    allocate(gr_ret(numprocs,nr,nr))
    allocate(gl_plus(numprocs,nl,nl))
    allocate(gr_minus(numprocs,nl,nl))
    allocate(gml_adv(numprocs,nl,nl))
    allocate(gmr_ret(numprocs,nr,nr))
    allocate(sl_adv(numprocs,nl,nl))
    allocate(sr_ret(numprocs,nr,nr))
    allocate(transl(ne,nk))
    allocate(transr(ne,nk))
    allocate(transl_s(ne,nk))
    allocate(transr_s(ne,nk))
    allocate(transl_ns(ne,nk))
    allocate(transr_ns(ne,nk))
    allocate(transl_reduce(ne,nk))
    allocate(transr_reduce(ne,nk))
    allocate(transl_s_reduce(ne,nk))
    allocate(transr_s_reduce(ne,nk))
    allocate(transl_ns_reduce(ne,nk))
    allocate(transr_ns_reduce(ne,nk))
    allocate(refll_s(ne,nk))
    allocate(reflr_s(ne,nk))
    allocate(refll_ns(ne,nk))
    allocate(reflr_ns(ne,nk))
    allocate(refll_s_reduce(ne,nk))
    allocate(reflr_s_reduce(ne,nk))
    allocate(refll_ns_reduce(ne,nk))
    allocate(reflr_ns_reduce(ne,nk))
    allocate(surface_dos_l(ne,nk))
    allocate(surface_dos_r(ne,nk))
    allocate(surface_dos_l_reduce(ne,nk))
    allocate(surface_dos_r_reduce(ne,nk))
    allocate(device_dos(ne,nk))
    allocate(device_dos_reduce(ne,nk))
    allocate(G_D_RL(numprocs,nr,nl))
    allocate(G_D_LR(numprocs,nl,nr))
    allocate(G_L(numprocs,nl,nl))
    allocate(G_R(numprocs,nr,nr))
    allocate(P1(nl,nl),Pinv1(nl,nl))
    allocate(P2(nl/n_bloch_y,nl/n_bloch_y),&
             Pinv2(nl/n_bloch_y,nl/n_bloch_y))

    gl_adv = 0.0d0
    gr_ret = 0.0d0
    gl_plus = 0.0d0
    gr_minus = 0.0d0
    gml_adv = 0.0d0
    gmr_ret = 0.0d0
    sl_adv = 0.0d0
    sr_ret = 0.0d0
    G_D_RL = 0.0d0
    G_D_LR = 0.0d0
    G_L = 0.0d0
    G_R = 0.0d0
    P1 = 0.0d0
    Pinv1 = 0.0d0
    P2 = 0.0d0
    Pinv2 = 0.0d0
    ! set up the permutation matrix for circular matrix inversion
    call set_pmatrix(nl,n_bloch_y,&
         reci_uc_l(2,:),latvec_uc_l(2,:),&
         P1,Pinv1)
    call set_pmatrix(nl/n_bloch_y,n_bloch_x,&
         reci_uc_l(1,:),latvec_uc_l(1,:),&
         P2,Pinv2)

    transl = 0.0d0
    transr = 0.0d0
    transl_s = 0.0d0
    transr_s = 0.0d0
    transl_ns = 0.0d0
    transr_ns = 0.0d0
    transl_reduce = 0.0d0
    transr_reduce = 0.0d0
    transl_s_reduce = 0.0d0
    transr_s_reduce = 0.0d0
    transl_ns_reduce = 0.0d0
    transr_ns_reduce = 0.0d0
    refll_s = 0.0d0
    reflr_s = 0.0d0
    refll_ns = 0.0d0
    reflr_ns = 0.0d0
    refll_s_reduce = 0.0d0
    reflr_s_reduce = 0.0d0
    refll_ns_reduce = 0.0d0
    reflr_ns_reduce = 0.0d0
    surface_dos_l = 0.0d0
    surface_dos_r = 0.0d0
    surface_dos_l_reduce = 0.0d0
    surface_dos_r_reduce = 0.0d0
    device_dos = 0.0d0
    device_dos_reduce = 0.0d0

    if (myid .eq. 0) then
        call blockwise_setup(Ham(1,:,:),norb)
        call transverse_uc_setup()
    end if
    call MPI_BARRIER(MPI_COMM_WORLD,ierr)

    ! broadcast non-array variable
    call MPI_BCAST(nlayer,1,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(nd,1,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(maxlen,1,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(natm_l_uc,1,MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(natm_r_uc,1,MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(nl_uc,1,MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(nr_uc,1,MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)

    ! still we need to run allocation on other cores.
    if (myid .gt. 0) then
        allocate(layer_list(nlayer),layerstart(nlayer),&
        layerend(nlayer),pidxL(nl),pidxR(nr),&
        L_orb_num_list(natm_l_uc),R_orb_num_list(natm_r_uc),&
        L_list(natm_l_uc),R_list(natm_r_uc),&
        pos_l(nl,3),pos_r(nr,3))
    end if

    ! finally we broadcast array variables
    call MPI_BCAST(layer_list,nlayer,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(layerstart,nlayer,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(layerend,nlayer,MPI_INTEGER,0,&
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(pidxL, nl, MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(pidxR, nr, MPI_INTEGER, 0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(L_orb_num_list,natm_l_uc,MPI_INTEGER,0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(R_orb_num_list,natm_r_uc,MPI_INTEGER,0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(L_list,natm_l_uc,MPI_INTEGER,0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(R_list,natm_r_uc,MPI_INTEGER,0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(pos_l,nl*3,MPI_DOUBLE_PRECISION,0, &
         MPI_COMM_WORLD, ierr)
    call MPI_BCAST(pos_r,nr*3,MPI_DOUBLE_PRECISION,0, &
         MPI_COMM_WORLD, ierr)

    allocate(orb_uc_l_idx(norb_uc_l),&
             orb_uc_r_idx(norb_uc_r))

    temp_count = 0
    do i = 1,nl
        p_crys_temp = matmul(pos_l(i,1:2),&
                      inv_real(latvec_uc(1:2,1:2)))
        if ((p_crys_temp(1).gt.-0.001).and.&
            (p_crys_temp(1).lt. 0.999).and.&
            (p_crys_temp(2).gt.-0.001).and.&
            (p_crys_temp(2).lt. 0.999)) then
            temp_count = temp_count + 1
            orb_uc_l_idx(temp_count) = i
        end if
    end do
    temp_count = 0
    do i = 1,nr
        p_crys_temp = matmul(pos_r(i,1:2),&
                      inv_real(latvec_uc(1:2,1:2)))
        if ((p_crys_temp(1).gt.-0.001).and.&
            (p_crys_temp(1).lt. 0.999).and.&
            (p_crys_temp(2).gt.-0.001).and.&
            (p_crys_temp(2).lt. 0.999)) then
            temp_count = temp_count + 1
            orb_uc_r_idx(temp_count) = i
        end if
    end do

    ! below is the start of the (heavy) calculation

    allocate(ldos(ne,numprocs,nlayer,maxlen))
    ldos = 0.0d0

    if (path_mode.ne.6) then
        do ik = 1,nkcore
        !call MPI_BARRIER(MPI_COMM_WORLD,ierr)
            call gen_ham_mpi(1,ik,Ham,eigvec,eig,norb)
            do ie = 1,ne

                call surface_green_mpi(ie,ik,Ham,norb,&
                                   gl_adv,gr_ret,gl_plus,gr_minus,&
                                   gml_adv,gmr_ret,&
                                   sl_adv,sr_ret,Egrid)
                call surface_ldos_mpi(ie,ik,&
                                   gl_adv,gr_ret,&
                                   surface_dos_l_reduce,surface_dos_r_reduce)

                call G_block_mpi(ie,ik,Ham,norb,&
                           gl_adv,gr_ret,&
                           gml_adv,gmr_ret,sl_adv,sr_ret,Egrid,&
                           transl_reduce(:,:),transr_reduce(:,:),&
                           G_D_RL(:,:,:),G_D_LR(:,:,:),&
                           G_L(:,:,:),G_R(:,:,:))

                call get_ldos_mpi(ie,ik,Ham,norb,gl_adv,gr_ret,&
                     gml_adv,gmr_ret,&
                     sl_adv,sr_ret,Egrid,ldos(:,:,:,:),device_dos_reduce(:,:))

                call vel_mat_mpi(ie,ik,Egrid,Ham,norb,&
                     gl_adv,gr_ret,gl_plus,gr_minus,&
                     gml_adv,gmr_ret,&
                     G_D_RL(:,:,:),G_D_LR(:,:,:),&
                     G_L(:,:,:),G_R(:,:,:),&
                     transl_s_reduce(:,:),transr_s_reduce(:,:),&
                     transl_ns_reduce(:,:),transr_ns_reduce(:,:),&
                     refll_s_reduce(:,:),reflr_s_reduce(:,:),&
                     refll_ns_reduce(:,:),reflr_ns_reduce(:,:),&
                     norb_pc_l,norb_pc_r,&
                     norb_uc_l,norb_uc_r)

                if (myid.eq.0) then
                    write(*,23,ADVANCE='NO') dble((ik-1)*ne+ie)/dble(nkcore*ne)*100.0d0
                    do i = 1,50
                        if ((i-1)*100/50 .le.&
                            int(dble((ik-1)*ne+ie)/dble(nkcore*ne)*100.0d0)) then
                            write(*,"(A)",ADVANCE='NO')'='
                        else
                            write(*,"(A)",ADVANCE='NO')' '
                        end if
                    end do
                    write(*,"(A)")']'
                    23  format ('Process: ',f6.2,' % [')
                end if
            end do
            call MPI_BARRIER(MPI_COMM_WORLD,ierr)
        end do
        call MPI_BARRIER(MPI_COMM_WORLD,ierr)
        call MPI_ALLREDUCE(surface_dos_l_reduce,surface_dos_l,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
        call MPI_ALLREDUCE(surface_dos_r_reduce,surface_dos_r,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
        call MPI_ALLREDUCE(device_dos_reduce,device_dos,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

         if (myid.eq.0) then
             call write_device_dos(device_dos)
             call write_surface_ldos(surface_dos_l,surface_dos_r)
         end if
    else
        do ik = 1,nkcore
        !call MPI_BARRIER(MPI_COMM_WORLD,ierr)
            call gen_ham_mpi(1,ik,Ham,eigvec,eig,norb)
            do ie = 1,ne

                call surface_green_mpi(ie,ik,Ham,norb,&
                                   gl_adv,gr_ret,gl_plus,gr_minus,&
                                   gml_adv,gmr_ret,&
                                   sl_adv,sr_ret,Egrid)
                call surface_ldos_mpi(ie,ik,&
                                   gl_adv,gr_ret,&
                                   surface_dos_l_reduce,surface_dos_r_reduce)
                if (myid.eq.0) then
                    write(*,24,ADVANCE='NO') dble((ik-1)*ne+ie)/dble(nkcore*ne)*100.0d0
                    do i = 1,50
                        if ((i-1)*100/50 .le.&
                            int(dble((ik-1)*ne+ie)/dble(nkcore*ne)*100.0d0)) then
                            write(*,"(A)",ADVANCE='NO')'='
                        else
                            write(*,"(A)",ADVANCE='NO')' '
                        end if
                    end do
                    write(*,"(A)")']'
                    24  format ('Process: ',f6.2,' % [')
                end if
            end do
            call MPI_BARRIER(MPI_COMM_WORLD,ierr)
        end do
        call MPI_BARRIER(MPI_COMM_WORLD,ierr)

        call MPI_ALLREDUCE(surface_dos_l_reduce,surface_dos_l,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
        call MPI_ALLREDUCE(surface_dos_r_reduce,surface_dos_r,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

         if (myid.eq.0) then
             call write_surface_ldos(surface_dos_l,surface_dos_r)
         end if
         call MPI_FINALIZE(ierr)
         stop
    end if

    call MPI_ALLREDUCE(transl_reduce,transl,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(transr_reduce,transr,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(transl_s_reduce,transl_s,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(transr_s_reduce,transr_s,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(transl_ns_reduce,transl_ns,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(transr_ns_reduce,transr_ns,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(refll_s_reduce,refll_s,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(reflr_s_reduce,reflr_s,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(refll_ns_reduce,refll_ns,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(reflr_ns_reduce,reflr_ns,ne*nk,&
         MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

    call MPI_BARRIER(MPI_COMM_WORLD,ierr)

    if (myid.eq.0) then
        if (path_mode.ne.1)then
            call write_trans(Egrid,&
            transl_s,transl_ns,&
            transr_s,transr_ns,&
            transl,transr,&
            refll_s,refll_ns,&
            reflr_s,reflr_s)
        end if
    end if

    call MPI_FINALIZE(ierr)

end program infortran


      MODULE blume_C
      USE vast_kind_param, ONLY:  DOUBLE
!...Created by Pacific-Sierra Research 77to90  4.3E  22:22:18  11/14/01
      REAL(DOUBLE), DIMENSION(4) :: COEFN2, COEFNK, COEFVK
      END MODULE blume_C

      MODULE nel_C
      USE vast_kind_param, ONLY:  DOUBLE
      use parameters_biotr_C
!...Created by Pacific-Sierra Research 77to90  4.3E  22:22:18  11/14/01
        integer, dimension(:), pointer :: IQN,IQL,IQMAX_
        integer, dimension(:), allocatable, target :: N,L,MAX_
        REAL(DOUBLE), dimension(:), pointer :: IQAZ
        REAL(DOUBLE), dimension(:), allocatable, target :: AZ
        REAL(DOUBLE), dimension(:,:), pointer :: IQP
        REAL(DOUBLE), dimension(:,:),allocatable,target :: P
        integer, dimension(7) :: IQ
        character(LEN=3), dimension(NWD) :: EL
        integer szX, szY
      END MODULE nel_C

      MODULE param_C
      USE vast_kind_param, ONLY:  DOUBLE
!...Created by Pacific-Sierra Research 77to90  4.3E  22:22:18  11/14/01
      INTEGER :: NO, ND, NWF, MASS, NCFG, IB, IC, ID, NSCF, NCLOSD
      INTEGER :: MSOO
      REAL(DOUBLE) :: H, H1, H3, CH, EH, RHO, Z, TOL, D0, D1, D2, D3, D4, D5, &
         D6, D8, D10, D12, D16, D30, FINE, RMASS
      EQUIVALENCE (MASS,MSOO)
      END MODULE param_C

      MODULE radial_C
      USE vast_kind_param, ONLY:  DOUBLE
!...Created by Pacific-Sierra Research 77to90  4.3E  22:22:18  11/14/01
      INTEGER, PARAMETER :: NOD = 220
      REAL(DOUBLE), DIMENSION(NOD) :: R, RR, R2, YK, YR, X
      END MODULE radial_C


      subroutine viirs(iwa)
      common /sixs_ffu/ s(1501),wlinf,wlsup
      real sr(16,1501),wli(16),wls(16)
      real wlinf,wlsup,s
      integer iwa,l,i

c
c    VIIRS band M1
c
      data (sr(1,l),l=1,1501)/ 61*0.,
     a 0.7,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.3,
     a1431*0./
c
c    VIIRS band M2
c
      data (sr(2,l),l=1,1501) / 74*0.,
     a 0.1,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.1,
     a1418*0./
c
c    VIIRS band M3
c
      data (sr(3,l),l=1,1501)/ 91*0.,
     a 0.3,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.7,
     a1401*0./
c
c    VIIRS band M4
c
      data (sr(4,l),l=1,1501)/ 118*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.5,
     a1374*0./
c
c    VIIRS band M5
c
      data (sr(5,l),l=1,1501)/ 165*0.,
     a 0.7,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.3,
     a1327*0./
c
c    VIIRS band M6
c
      data (sr(6,l),l=1,1501)/ 195*0.,
     a 0.1,1.0,1.0,1.0,1.0,
     a 1.0,0.9,
     a1299*0./
c
c    VIIRS band M7
c
      data (sr(7,l),l=1,1501)/ 238*0.,
     a 0.3,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,0.3,
     a1246*0./
c
c    VIIRS band M8
c
      data (sr(8,l),l=1,1501)/ 392*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,0.5,
     a1100*0./
c
c    VIIRS band M9
c
      data (sr(9,l),l=1,1501)/ 448*0.,
     a 0.3,1.0,1.0,1.0,1.0,
     a 1.0,0.7,
     a1046*0./
c
c    VIIRS band M10
c
      data (sr(10,l),l=1,1501)/ 532*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,0.5,
     a944*0./
c
c    VIIRS band M11
c
      data (sr(11,l),l=1,1501)/ 790*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 0.5,
     a690*0./
c
c    VIIRS band M12
c
      data (sr(12,l),l=1,1501)/ 1344*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,0.5,
     a84*0./
c
c    VIIRS band I1
c
      data (sr(13,l),l=1,1501)/ 140*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,0.5,
     a1328*0./
c
c    VIIRS band I2
c
      data (sr(14,l),l=1,1501)/ 238*0.,
     a 0.3,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,0.3,
     a1246*0./
c
c    VIIRS band I3
c
      data (sr(15,l),l=1,1501)/ 532*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,0.5,
     a944*0./
c
c    VIIRS band I4
c
      data (sr(16,l),l=1,1501)/ 1320*0.,
     a 0.5,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,1.0,1.0,1.0,
     a 1.0,1.0,0.5,
     a28*0./

c
      wli(1)=0.4025
      wls(1)=0.4225
      wli(2)=0.4350
      wls(2)=0.4550
      wli(3)=0.4775
      wls(3)=0.4975
      wli(4)=0.5450
      wls(4)=0.5650
      wli(5)=0.6625
      wls(5)=0.6825
      wli(6)=0.7375
      wls(6)=0.7525
      wli(7)=0.8450
      wls(7)=0.8850
      wli(8)=1.2300
      wls(8)=1.2500
      wli(9)=1.3700
      wls(9)=1.3850
      wli(10)=1.5800
      wls(10)=1.6400
      wli(11)=2.2250
      wls(11)=2.2750
      wli(12)=3.6100
      wls(12)=3.7900
      wli(13)=0.6000
      wls(13)=0.6800
      wli(14)=0.8450
      wls(14)=0.8850
      wli(15)=1.5800
      wls(15)=1.6400
      wli(16)=3.5500
      wls(16)=3.9300
      do 1 i=1,1501
      s(i)=sr(iwa,i)
    1 continue
      wlinf=wli(iwa)
      wlsup=wls(iwa)
      return
      end


      SUBROUTINE WHEELS(ITEST,RWHEEL)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      COMMON/CONSTS/PI,TWOPI,RADIAN
C
      COMMON/OUTTHR/SMAGB(3),XMB(3),RWHEL(3)
C
      COMMON/PWHEEL/XMOMIN(3),DVMOM(3),VINIT(3),VMOM(3)
C
      COMMON/CWHEEL/VW(3),VSUR(3),VSDR(3)
C
      COMMON/HWHEEL/HWM(3)
C
      COMMON/CNOISE/VNS2(10),VNS1(10),VNSN(10),T1,T2
      COMMON/CSTAT /X(20),XDOT(20),CPARM(43)
      COMMON/ICSADM/LDUM,IRAND,NCHAN
      EQUIVALENCE(CPARM(1),TAUS),(CPARM(2),TAU1),(CPARM(3),TAU2)
      EQUIVALENCE(CPARM(4),TAUF),(CPARM(5),AKS),(CPARM(6),AKC)
      EQUIVALENCE(CPARM(7),AKA),(CPARM(8),AKF),(CPARM(9),AKB)
      EQUIVALENCE(CPARM(10),AKT),(CPARM(11),TAURAT),(CPARM(12),VOPLIM)
      EQUIVALENCE(CPARM(13),AKM1),(CPARM(14),TAUM1),(CPARM(15),VBIAS)
      EQUIVALENCE(CPARM(16),TCOUL),(CPARM(17),OMMIN)
      EQUIVALENCE(CPARM(18),ZETAS)
      EQUIVALENCE(CPARM(41),PBIAS),(CPARM(42),RBIAS)
      DIMENSION SSN(5),TCOR(5)
      EQUIVALENCE(CPARM(31),SSN(1)),(CPARM(36),TCOR(1))
      EQUIVALENCE(CPARM(19),AKM2),(CPARM(20),TAUM2),(CPARM(21),SIGND)
      EQUIVALENCE(CPARM(22),RLIM),(CPARM(23),TMOTUP),(CPARM(24),TMOTDN)
C
      COMMON/CFILTW/TSTART,DVWP(3),DVWM(3),TREF1,TREF2
C
C
      COMMON /ICNTRL/KNTRL(10)
      COMMON /JCNTRL/NCNTRL,MCNTRL,MAPCNT(20)
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON /VARBLS/DEPEND(150),DERIV(150)
C
      DIMENSION RWHEEL(3),HM(3),WB(3)
C
      DIMENSION DV(3)
C
C
      IF(ITEST.EQ.2) GO TO 100
      IF(KNTRL(1) .NE. 0) GO TO 50
C
C     WHEEL SPEED GIVEN BY OPEN-LOOP INITIAL-RATE,CONSTANT ACCEL, LIMIT
      TST=TIME-TSTART
      DO 10 I=1,3
      VW(I)=VMOM(I)+DVMOM(I)*TST
      DV(I)=DVMOM(I)
      IF(VW(I).GT.VSUR(I)) VW(I)=VSUR(I)
      IF(VW(I).LT.VSDR(I)) VW(I)=VSDR(I)
      IF(VW(I).EQ.VSUR(I).AND.DV(I).GT.0.0D0) DV(I)=0.0D0
      IF(VW(I).EQ.VSDR(I).AND.DV(I).LT.0.0D0) DV(I)=0.0D0
   10 CONTINUE
      GO TO 190
C
C     ACTIVE CONTROL OF WHEEL SPEED   ( RCA DYNAMICS EXPLORER-B)
C
C     PICK UP STATE VARIABLES OF CONTROL SYSTEM
50     DO 55 I=1,NCNTRL
      J=MAPCNT(I)
55    X(J)=DEPEND(I+MCNTRL)
C
      OMREL=X(15)-OMEG(2)
C     GENERATE NOISE
      IF(NCHAN.NE.0) CALL EXPN(TIME,T2,T1,VNS2,VNS1,SSN,TCOR,VNSN)
C
C     SPACECRAFT ATTITUDE
      CALL DEBANG(YAW,ROLL,PITCH)
      PITCH=PITCH+PBIAS+VNSN(1)
      ROLL=ROLL+RBIAS+VNSN(2)
C
C     PITCH SENSOR
      EPITCH=PITCH
      X(17)=EPITCH
      IF(KNTRL(1) .EQ. 1) GO TO 75
C
C    4TH ORDER SENSOR MODEL
      XDOT(4)=(EPITCH-X(3)-2.0D0*ZETAS*X(4))/TAUS
      XDOT(3)=X(4)/TAUS
      XDOT(2)=(AKS*X(3)-X(1)-2.0D0*ZETAS*X(2))/TAUS
      XDOT(1)=X(2)/TAUS
      GO TO 76
C
C     2ND ORDER SENSOR MODEL
75    CONTINUE
      XDOT(2)=(EPITCH-X(2))/TAUS
      XDOT(1)=(AKS*X(2)-X(1))/TAUS
76    CONTINUE
C
C     TEST FOR NUTATION DAMPER
      IF(KNTRL(2) .EQ. 0) GO TO 80
C     CLIP ROLL SENSOR OUTPUT
      X6=X(6)
      WS=DABS(X6)
      IF(WS.GT.RLIM) X6=RLIM*X6/WS
C
C     NUTATION DAMPER--PHASE SHIFT CIRCUIT
      AKM=AKM1
      TAUM=TAUM1
      IF(KNTRL(2).EQ.1) GO TO 78
      AKM=AKM2
      TAUM=TAUM2
C
78    CONTINUE
C
      AKMT=AKM/TAUM
      XDOT(19)=-(AKMT*X6+X(19))/TAUM
      XDOT(20)=(AKMT*X6+X(19)-X(20))/TAUM
      VNUDAM=SIGND*X(20)
C
C     ROLL SENSOR
      EROLL=ROLL
      X(18)=EROLL
C     TEST SENSOR ORDER
      IF(KNTRL(1) .EQ. 1) GO TO 85
C
C     4TH ORDER MODEL
      XDOT(9)=(EROLL-X(8)-2.0D0*ZETAS*X(9))/TAUS
      XDOT(8)=X(9)/TAUS
      XDOT(7)=(AKS*X(8)-X(6)-2.0D0*ZETAS*X(7))/TAUS
      XDOT(6)=X(7)/TAUS
      GO TO 86
C
C     2ND ORDER MODEL
85    CONTINUE
      XDOT(7)=(EROLL-X(7))/TAUS
      XDOT(6)=(AKS*X(7)-X(6))/TAUS
86    CONTINUE
      GO TO 90
C
C     NO NUTATION DAMPER
80    VNUDAM=0.
C
C     PITCH COMPENSATION AMPLIFIER
90    SVIPCA=(X(1)+VNUDAM)*AKC
C     COMPUTE OUTPUT, ASSUMING NO SATURATION
      TAURAT=TAU1/TAU2
      VOPCA=X(11)+SVIPCA*TAURAT
      WWW1=DABS(VOPCA)
C     SATURATION
      IF(WWW1.GT.VOPLIM) VOPCA=VOPLIM*VOPCA/WWW1
      XDOT(11)=(SVIPCA-VOPCA)/TAU2
      X(16)=VOPCA
C
C     TACHOMETER
54    IF(KNTRL(3) .EQ. 0) GO TO 56
C        1ST ORDER TACHOMETER MODEL
      XDOT(13)=(AKF*OMREL-X(13))/TAUF
         GO TO 57
C
C          NO DYNAMICS IN TACHOMETER
56    X(13)=AKF*OMREL
C
C     SUMMING AND POWER AMP
57    VOPA=AKA*(VOPCA+VBIAS+VNSN(3)-X(13))
C
C     MOTOR TORQUE
      TMOTOR=AKT*(VOPA-AKB*OMREL)
      IF(TMOTOR.GT.TMOTUP) TMOTOR=TMOTUP
      IF(TMOTOR.LT.TMOTDN) TMOTOR=TMOTDN
      TMOTOR=TMOTOR-OMREL*TCOUL/(OMMIN+DABS(OMREL))
      X(14)=TMOTOR
C     WHEEL DYNAMICS
      XDOT(15)=TMOTOR/XMOMIN(2)
C
C     COLLECT CONTROL DERIVATIVES INTO STATE DERIVATIVE VECTOR
      DO 60 I=1,NCNTRL
      J=MAPCNT(I)
60    DERIV(I+MCNTRL)=XDOT(J)
C
C      WIRE THINGS FOR THE REST OF THE PROGRAM
      VW(1)=0.
      VW(2)=X(15)/RADIAN
      VW(3)=0.
      DV(1)=0.
      DV(2)=XDOT(15)/RADIAN
      DV(3)=0.
C
C
C     INTERACTION WITH VEHICLE
190   DO 30 I=1,3
      WB(I)=OMEG(I)
      HM(I)=VW(I)*XMOMIN(I)
30    HWM(I)=HM(I)*RADIAN
      RWHEEL(1)=(-XMOMIN(1)*DV(1)+HM(2)*WB(3)-HM(3)*WB(2))*RADIAN
      RWHEEL(2)=(-XMOMIN(2)*DV(2)+HM(3)*WB(1)-HM(1)*WB(3))*RADIAN
      RWHEEL(3)=(-XMOMIN(3)*DV(3)+HM(1)*WB(2)-HM(2)*WB(1))*RADIAN
      RWHEL(1)=RWHEEL(1)
      RWHEL(2)=RWHEEL(2)
      RWHEL(3)=RWHEEL(3)
      GO TO 150
C
C     UPDATE INITIAL VALUES FOR CONTINUING TRAJECTORY
100   DO 120 I=1,3
120   VMOM(I)=VW(I)
C
150   RETURN
      END


!
! SPDX-License-Identifier: MIT
!
!--------------------------------------------------------------------------------------------------------------------
! FluTAS -- Fluid Transport Accelerated Solver
!
!  a. Menu Title: FluTAS_VoF_ht;
!  b. Feautures of FluTAS_VoF_ht:
!      --> two-fluid solver with VoF with heat transfer;
!      --> both Oberbeck-Boussinesq approximations and low Mach in the gas phase;
!      --> allow for density and viscosity mismatch;
!      --> momentum advanced with Adams-Bashforth (explicit diffusion);
!      --> pressure equation solved with FFT-based direct solver.
!--------------------------------------------------------------------------------------------------------------------
!
program flutas
  !
  ! module declaration
  !  note: --> import what you really neeed
  !
  use iso_c_binding , only: C_PTR
  use mpi
  use decomp_2d
  use mod_bound     , only: boundp,updt_rhs_b,bounduvw
  use mod_chkdiv    , only: chkdiv
  use mod_chkdt     , only: chkdt
  use mod_common_mpi, only: myid,ierr,comm_cart,n_z,ijk_start,ipencil
  use mod_correc    , only: correc
  use mod_debug     , only: chkmean
  use mod_fft       , only: fftini,fftend
  use mod_fillps    , only: fillps
  use mod_initflow  , only: initflow
  use mod_initgrid  , only: initgrid
  use mod_initmpi   , only: initmpi,halo_gen
#if defined(_OPENACC)
  use mod_initmpi   , only: alloc_buf
#endif
  use mod_initsolver, only: initsolver
  use mod_load      , only: load, load_scalar
  use mod_rk        , only: rk
  use mod_output    , only: out0d,out1d,out1d_2,out2d,out3d,write_visu_2d,write_visu_3d
  use mod_param     , only: lx,ly,lz,dx,dy,dz,dxi,dyi,dzi,small, &
                            cbcvel,bcvel,cbcpre,bcpre, &
                            icheck,iout0d,iout1d,iout2d,iout3d,isave, &
                            nstep,time_max,tw_max,stop_type,restart, &
                            cfl,     &
                            constant_dt,dt_input, &
                            inivel,  &
                            itot,jtot,ktot,dims_in, &
                            nthreadsmax, &
                            gr, &
                            is_outflow,no_outflow,is_forced,bforce, &
                            rho1,rho2,rho0,mu1,mu2,cbcvof,bcvof,late_init,i_late_init, &
#if defined(_DO_POSTPROC)
                            do_avg,time_deltai,&
                            avg_dir,&
                            do_favre,&
                            do_wall,wall_deltai,&
#endif
                            initmp, &
                            cbctmp,bctmp, &
                            cp1,cv1,kappa1, &
                            cp2,cv2,kappa2, &
                            tl0,tg0, &
                            rho0, &
                            n,ng,l,dl,dli, &
                            read_input, dpdl
  !
  use mod_sanity    , only: test_sanity
  use mod_initflow  , only: inittmp
  use mod_rks       , only: ab2_tmp
#if defined(_OPENACC)
  use mod_solver    , only: solver
#else
  use mod_solver_cpu, only: solver_cpu
#endif
  use mod_types
  use mod_vof       , only: initvof,advvof,update_vof,update_property,alloc_vof_var
#if defined(_DO_POSTPROC)
  use mod_post      , only: time_avg,wall_avg,compute_vorticity,mixed_variables
#endif
#if defined(_OPENACC)
  use cudafor
  use mod_common_mpi, only: mydev
#endif
#if defined(_USE_NVTX)
  use nvtx
#endif
  !
  !$ use omp_lib
  !
  implicit none
  !
  ! Variables declaration
  !  note: --> first decleare arrays, then the other variables;
  !        --> order of declaration: type, dimension, allocatable;
  !        --> remember to deallocate at the end.
  !
  real(rp), dimension(:,:,:)  , allocatable :: u,v,w,p,up,vp,wp,pp
  real(rp), dimension(:,:,:)  , allocatable :: pold
  !
  real(rp), dimension(:,:,:)  , allocatable :: psi,mu,rho,kappa
  real(rp), dimension(:,:,:,:), allocatable :: cur_t
  real(rp), dimension(:,:,:,:), allocatable :: nor
  real(rp), dimension(:,:,:)  , allocatable :: d_thinc
  !
  real(rp), dimension(:,:,:)  , allocatable :: tmp
  real(rp), dimension(:,:,:)  , allocatable :: dtmpdtrk
  real(rp), dimension(:,:,:)  , allocatable :: dtmpdtrkold
  real(rp), dimension(:,:,:)  , allocatable :: ka,cpp
  real(rp), dimension(:), allocatable :: dzc  ,dzf  ,zc  ,zf  ,dzci  ,dzfi
  real(rp), dimension(:), allocatable :: dzc_g,dzf_g,zc_g,zf_g,dzci_g,dzfi_g
  !
  real(rp), dimension(:,:,:), pointer :: dudtrko,dvdtrko,dwdtrko
  !
  type(C_PTR), dimension(2,2) :: arrplanp
  real(rp), allocatable, dimension(:,:) :: lambdaxyp
  real(rp), allocatable, dimension(:)   :: ap,bp,cp
  real(rp) :: normfftp
  !
  type rhs_bound
#if defined(_OPENACC)
   real(rp), allocatable, dimension(:,:,:), managed :: x,y,z
#else
   real(rp), allocatable, dimension(:,:,:) :: x,y,z
#endif
  end type rhs_bound
  type(rhs_bound), allocatable :: rhsbp
  !
  real(rp), dimension(3) :: f
  real(rp) :: dt,dti,dtmax,time,dtrk,dtrki,divtot,divmax
  real(rp) :: dto
#if defined(_TIMING)
  real(rp) :: dt12,dt12av,dt12min,dt12max
#endif
  !
  integer, dimension(3)   :: halo_u,halo_up,halo_p,halo_d,halo_v,halo_t
  integer, dimension(3)   :: dims
  integer, dimension(3,3) :: dims_xyz
  integer  :: nh_d,nh_u,nh_up,nh_p,nh_v,nh_t

  integer  :: i,j,k,im,ip,jm,jp,km,kp
  integer  :: irk,istep
  character(len=1) :: action_load
  logical  :: is_first_vel,is_data, is_first_tmp
  !
  real(rp) :: meanvel,meanvelu,meanvelv,meanvelw
  real(rp), dimension(3) :: dpdl_c
  real(rp), dimension(10) :: var
  !
  character(len=9)   :: fldnum
  character(len=100) :: datadir
  real(rp) :: f1d,f2d,f3d
  real(rp) :: twi,tw
  integer :: kk
  logical :: is_done,kill
  real(rp) :: rho0i
#if defined(_OPENACC)
  attributes(managed) :: pold, kappa, mu, rho, psi, d_thinc, cur_t, nor
  attributes(managed) :: u, v, w, p, up, vp, wp, pp
  attributes(managed) :: tmp, ka, cpp, dtmpdtrk, dtmpdtrkold
  integer :: istat
  integer(kind=cuda_count_kind) :: freeMem, totMem
  integer(rp) :: totEle
  attributes(managed) :: dzc, dzf, zc, zf, dzci, dzfi, lambdaxyp, ap, bp, cp, rhsbp
  attributes(managed) :: dudtrko, dvdtrko, dwdtrko
#endif
  !if we don't use dropcheck.f90 we can comment the next line
  !real(rp) :: xd,yd,zd,ut,vt,wt,zcd,ycd,xcd,vol
  real(rp) :: vof_min,vof_max,vol_p1
  real(rp) :: aux
  integer :: ii,jj!,kk
#if defined(_DO_POSTPROC)
  real(rp), allocatable, dimension(:,:,:) :: uv,vw,wu
  real(rp), allocatable, dimension(:,:,:) :: vorx
  real(rp), allocatable, dimension(:) :: u_avg_g,v_avg_g,w_avg_g,u_sqr_g,v_sqr_g,w_sqr_g
  real(rp), allocatable, dimension(:) :: u_avg_l,v_avg_l,w_avg_l,u_sqr_l,v_sqr_l,w_sqr_l
  real(rp), allocatable, dimension(:) :: uv_avg_g,vw_avg_g,wu_avg_g,uv_sqr_g,vw_sqr_g,wu_sqr_g
  real(rp), allocatable, dimension(:) :: uv_avg_l,vw_avg_l,wu_avg_l,uv_sqr_l,vw_sqr_l,wu_sqr_l
  real(rp), allocatable, dimension(:) :: vorx_avg_g,vorx_sqr_g
  real(rp), allocatable, dimension(:) :: vorx_avg_l,vorx_sqr_l
  real(rp), allocatable, dimension(:) :: void_avg,void_sqr
  real(rp) :: u_vol_avg_g,u_vol_sqr_g,v_vol_avg_g,v_vol_sqr_g,w_vol_avg_g,w_vol_sqr_g
  real(rp) :: u_vol_avg_l,u_vol_sqr_l,v_vol_avg_l,v_vol_sqr_l,w_vol_avg_l,w_vol_sqr_l
  real(rp) :: uv_vol_avg_g,uv_vol_sqr_g,vw_vol_avg_g,vw_vol_sqr_g,wu_vol_avg_g,wu_vol_sqr_g
  real(rp) :: uv_vol_avg_l,uv_vol_sqr_l,vw_vol_avg_l,vw_vol_sqr_l,wu_vol_avg_l,wu_vol_sqr_l
  real(rp) :: vorx_vol_avg_g,vorx_vol_sqr_g
  real(rp) :: vorx_vol_avg_l,vorx_vol_sqr_l
  real(rp) :: vory_vol_avg_g,vory_vol_sqr_g
  real(rp) :: vory_vol_avg_l,vory_vol_sqr_l
  real(rp) :: vorz_vol_avg_g,vorz_vol_sqr_g
  real(rp) :: vorz_vol_avg_l,vorz_vol_sqr_l
  real(rp) :: void_vol_avg,void_vol_sqr
  integer  :: i_av
  real(rp), allocatable, dimension(:,:,:) :: utmp,vtmp,wtmp
  real(rp), allocatable, dimension(:) :: tmp_avg_g,tmp_sqr_g
  real(rp), allocatable, dimension(:) :: tmp_avg_l,tmp_sqr_l
  real(rp), allocatable, dimension(:) :: utmp_avg_g,vtmp_avg_g,wtmp_avg_g,utmp_sqr_g,vtmp_sqr_g,wtmp_sqr_g
  real(rp), allocatable, dimension(:) :: utmp_avg_l,vtmp_avg_l,wtmp_avg_l,utmp_sqr_l,vtmp_sqr_l,wtmp_sqr_l
  real(rp) :: tmp_vol_avg_g,tmp_vol_sqr_g
  real(rp) :: tmp_vol_avg_l,tmp_vol_sqr_l
  real(rp) :: utmp_vol_avg_g,utmp_vol_sqr_g,vtmp_vol_avg_g,vtmp_vol_sqr_g,wtmp_vol_avg_g,wtmp_vol_sqr_g
  real(rp) :: utmp_vol_avg_l,utmp_vol_sqr_l,vtmp_vol_avg_l,vtmp_vol_sqr_l,wtmp_vol_avg_l,wtmp_vol_sqr_l
#if defined(_OPENACC)
  attributes(managed) :: vorx,uv,vw,wu,utmp,vtmp,wtmp
  attributes(managed) :: u_avg_g,v_avg_g,w_avg_g,u_sqr_g,v_sqr_g,w_sqr_g
  attributes(managed) :: u_avg_l,v_avg_l,w_avg_l,u_sqr_l,v_sqr_l,w_sqr_l
  attributes(managed) :: uv_avg_g,vw_avg_g,wu_avg_g,uv_sqr_g,vw_sqr_g,wu_sqr_g
  attributes(managed) :: uv_avg_l,vw_avg_l,wu_avg_l,uv_sqr_l,vw_sqr_l,wu_sqr_l
  attributes(managed) :: vorx_avg_g,vorx_sqr_g
  attributes(managed) :: vorx_avg_l,vorx_sqr_l
  attributes(managed) :: void_avg,void_sqr
  attributes(managed) :: tmp_avg_g,tmp_sqr_g
  attributes(managed) :: tmp_avg_l,tmp_sqr_l
  attributes(managed) :: utmp_avg_g,vtmp_avg_g,wtmp_avg_g,utmp_sqr_g,vtmp_sqr_g,wtmp_sqr_g
  attributes(managed) :: utmp_avg_l,vtmp_avg_l,wtmp_avg_l,utmp_sqr_l,vtmp_sqr_l,wtmp_sqr_l
#endif
#endif
  !
  call MPI_INIT(ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr)
  !
  ! read parameter file
  !
#if defined(_USE_NVTX)
  call nvtxStartRange("readInput")
#endif
  call read_input(myid)
#if defined(_USE_NVTX)
  call nvtxEndRange
#endif
  !
  ! create data folder and subfolders for post-processing, if they do not exist.
  !
  inquire(file='data/',exist=is_data)
  if(.not.is_data.and.myid.eq.0) call execute_command_line('mkdir -p data')
  datadir = 'data/'
#if defined(_DO_POSTPROC)
  inquire(file='data/post/',exist=is_data)
  if(.not.is_data.and.myid.eq.0) call execute_command_line('mkdir -p data/post')
  inquire(file='data/post/time_averaging/',exist=is_data)
  if(do_avg.and..not.is_data.and.myid.eq.0) call execute_command_line('mkdir -p data/post/time_averaging')
  if(do_avg) i_av = 0
  inquire(file='data/post/wall/',exist=is_data)
  if(do_wall.and..not.is_data.and.myid.eq.0) call execute_command_line('mkdir -p data/post/wall')
#endif
  !
  ! initialize MPI/OpenMP
  !
  !$call omp_set_num_threads(nthreadsmax)
#if defined(_USE_NVTX)
  call nvtxStartRange("initmpi")
#endif
  call initmpi(.false.,ng,cbcpre,dims_in,dims_xyz,dims,n)
#if defined(_USE_NVTX)
  call nvtxEndRange
#endif
  !
  twi = MPI_WTIME()
  !
  ! halo calculation (for the variables we generally
  !                   do enlarge the stencil support)
  !
  nh_u = 3
  nh_t = 3
  nh_d = nh_u ! take the maximum of the previous (e.g., max(nh_u,nh_t))
  !
  ! allocate memory
  !
#if defined(_USE_NVTX)
  call nvtxStartRange("variable_allocations")
#endif
  allocate(p(0:n(1)+1,0:n(2)+1,0:n(3)+1) , &
           u(1-nh_u:n(1)+nh_u,1-nh_u:n(2)+nh_u,1-nh_u:n(3)+nh_u) , &
           v(1-nh_u:n(1)+nh_u,1-nh_u:n(2)+nh_u,1-nh_u:n(3)+nh_u) , &
           w(1-nh_u:n(1)+nh_u,1-nh_u:n(2)+nh_u,1-nh_u:n(3)+nh_u) , &
           up(0:n(1)+1,0:n(2)+1,0:n(3)+1), &
           vp(0:n(1)+1,0:n(2)+1,0:n(3)+1), &
           wp(0:n(1)+1,0:n(2)+1,0:n(3)+1), &
           pp(0:n(1)+1,0:n(2)+1,0:n(3)+1))
  allocate(tmp(1-nh_t:n(1)+nh_t,1-nh_t:n(2)+nh_t,1-nh_t:n(3)+nh_t), &
            ka(0:n(1)+1,0:n(2)+1,0:n(3)+1), &
           cpp(0:n(1)+1,0:n(2)+1,0:n(3)+1), &
              dtmpdtrk(1:n(1),1:n(2),1:n(3)),&
           dtmpdtrkold(1:n(1),1:n(2),1:n(3)))
  allocate(dudtrko(n(1),n(2),n(3)), &
           dvdtrko(n(1),n(2),n(3)), &
           dwdtrko(n(1),n(2),n(3)))
  allocate(pold(   0:n(1)+1,0:n(2)+1,0:n(3)+1)   , &
           psi(    0:n(1)+1,0:n(2)+1,0:n(3)+1)   , &
           kappa(  0:n(1)+1,0:n(2)+1,0:n(3)+1)   , &
           mu(     0:n(1)+1,0:n(2)+1,0:n(3)+1)   , &
           rho(    0:n(1)+1,0:n(2)+1,0:n(3)+1)   , &
           cur_t(  0:n(1)+1,0:n(2)+1,0:n(3)+1,6) , &
           nor(    0:n(1)+1,0:n(2)+1,0:n(3)+1,3) , &
           d_thinc(0:n(1)+1,0:n(2)+1,0:n(3)+1))
  allocate(lambdaxyp(n_z(1),n_z(2)))
  allocate(ap(n_z(3)),bp(n_z(3)),cp(n_z(3)))
  allocate(dzc( 1-nh_d:n(3)+nh_d), &
           dzf( 1-nh_d:n(3)+nh_d), &
           zc(  1-nh_d:n(3)+nh_d), &
           zf(  1-nh_d:n(3)+nh_d), &
           dzci(1-nh_d:n(3)+nh_d), &
           dzfi(1-nh_d:n(3)+nh_d))
  allocate(dzc_g( 1-nh_d:ng(3)+nh_d), &
           dzf_g( 1-nh_d:ng(3)+nh_d), &
           zc_g(  1-nh_d:ng(3)+nh_d), &
           zf_g(  1-nh_d:ng(3)+nh_d), &
           dzci_g(1-nh_d:ng(3)+nh_d), &
           dzfi_g(1-nh_d:ng(3)+nh_d))
  allocate(rhsbp)
  allocate(rhsbp%x(n(2),n(3),0:1), &
           rhsbp%y(n(1),n(3),0:1), &
           rhsbp%z(n(1),n(2),0:1))
  !
  ! prefetching of the variables (TODO: remember to add the one of x-pencil!)
  !
#if defined(_OPENACC)
  istat = cudaMemAdvise(u, size(u), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(v, size(v), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(w, size(w), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(p, size(p), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(up, size(up), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(vp, size(vp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(wp, size(wp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(pp, size(pp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(dudtrko, size(dudtrko), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(dvdtrko, size(dvdtrko), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(dwdtrko, size(dwdtrko), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemPrefetchAsync(u, size(u), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(v, size(v), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(w, size(w), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(p, size(p), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(up, size(up), mydev, 0)
  istat = cudaMemPrefetchAsync(vp, size(vp), mydev, 0)
  istat = cudaMemPrefetchAsync(wp, size(wp), mydev, 0)
  istat = cudaMemPrefetchAsync(pp, size(pp), mydev, 0)
  istat = cudaMemPrefetchAsync(dudtrko, size(dudtrko), mydev, 0)
  istat = cudaMemPrefetchAsync(dvdtrko, size(dvdtrko), mydev, 0)
  istat = cudaMemPrefetchAsync(dwdtrko, size(dwdtrko), mydev, 0)
  !
  istat = cudaMemAdvise(tmp, size(tmp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise( ka, size( ka), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(cpp, size(cpp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(   dtmpdtrk,    size(dtmpdtrk), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(dtmpdtrkold, size(dtmpdtrkold), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemPrefetchAsync(tmp, size(tmp), mydev, 0)
  istat = cudaMemPrefetchAsync(ka, size(ka), mydev, 0)
  istat = cudaMemPrefetchAsync(cpp, size(cpp), mydev, 0)
  istat = cudaMemPrefetchAsync(   dtmpdtrk,    size(dtmpdtrk), mydev, 0)
  istat = cudaMemPrefetchAsync(dtmpdtrkold, size(dtmpdtrkold), mydev, 0)
  !
  istat = cudaMemAdvise(rhsbp%x, size(rhsbp%x), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(rhsbp%y, size(rhsbp%y), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(rhsbp%z, size(rhsbp%z), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemPrefetchAsync(rhsbp%x, size(rhsbp%x), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(rhsbp%y, size(rhsbp%y), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(rhsbp%z, size(rhsbp%z), cudaCpuDeviceId, 0)
  !
  istat = cudaMemAdvise(zc, size(zc), cudaMemAdviseSetReadMostly, 0)
  istat = cudaMemAdvise(zf, size(zf), cudaMemAdviseSetReadMostly, 0)
  istat = cudaMemAdvise(dzc, size(dzc), cudaMemAdviseSetReadMostly, 0)
  istat = cudaMemAdvise(dzf, size(dzf), cudaMemAdviseSetReadMostly, 0)
  istat = cudaMemAdvise(dzci, size(dzci), cudaMemAdviseSetReadMostly, 0)
  istat = cudaMemAdvise(dzfi, size(dzfi), cudaMemAdviseSetReadMostly, 0)
  !
#if defined(_USE_VOF)
  istat = cudaMemAdvise(mu, size(mu), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(pold, size(pold), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(rho, size(rho), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(kappa, size(kappa), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(psi, size(psi), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(d_thinc, size(d_thinc), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(nor, size(nor), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(cur_t, size(cur_t), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemPrefetchAsync(pold, size(pold), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(mu, size(mu), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(rho, size(rho), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(kappa, size(kappa), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(psi, size(psi), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(d_thinc, size(d_thinc), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(nor, size(nor), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(cur_t, size(cur_t), cudaCpuDeviceId, 0)
#endif
  !
#if defined(_DO_POSTPROC)
  istat = cudaMemAdvise(vorx, size(vorx), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(  uv,   size(uv), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(  vw,   size(vw), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(  wu,   size(wu), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(utmp, size(utmp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(vtmp, size(vtmp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemAdvise(wtmp, size(wtmp), cudaMemAdviseSetPreferredLocation, mydev)
  istat = cudaMemPrefetchAsync(vorx, size(vorx), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(  uv,   size(uv), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(  vw,   size(vw), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(  wu,   size(wu), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(utmp, size(utmp), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(vtmp, size(vtmp), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(wtmp, size(wtmp), cudaCpuDeviceId, 0)
#endif
  !
#endif
#if defined(_USE_NVTX)
  call nvtxEndRange
#endif
  !
  if(myid.eq.0) print*, '*******************************'
  if(myid.eq.0) print*, '*** Beginning of simulation ***'
  if(myid.eq.0) print*, '*******************************'
#if defined(_OPENACC)
  if(myid.eq.0) then
    print*, ' GPU accelerated version, grid size:', n(1)*dims(1), n(2)*dims(2), n(3)*dims(3)
  endif
#endif
  !
  ! halo calculation (for the variables we generally
  !                   do not enlarge the stencil support)
  !
  nh_p  = abs(lbound(p  ,1))+1
  nh_up = abs(lbound(up ,1))+1
  nh_v  = abs(lbound(psi,1))+1
  !
  ! halo generation
  !
  call halo_gen(n,nh_u ,halo_u )
  call halo_gen(n,nh_t ,halo_t )
  call halo_gen(n,nh_p ,halo_p )
  call halo_gen(n,nh_up,halo_up)
  call halo_gen(n,nh_v ,halo_v )
  call halo_gen(n,nh_d ,halo_d )
  !
#if defined(_OPENACC)
  !
  ! Allocate buffers for GPU halo communications
  !
  call alloc_buf(n,nh_d)
  !
#endif
  !
  ! initialize the grid (using global variables along z)
  !
#if defined(_OPENACC)
  istat = cudaMemPrefetchAsync(zc, size(zc), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(zf, size(zf), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(dzc, size(dzc), cudaCpuDeviceId, 0)
  istat = cudaMemPrefetchAsync(dzf, size(dzf), cudaCpuDeviceId, 0)
#endif
#if defined(_USE_NVTX)
  call nvtxStartRange("initgrid")
#endif
  call initgrid(inivel,ng(3),gr,lz,nh_d,dzc_g,dzf_g,zc_g,zf_g)
#if defined(_USE_NVTX)
  call nvtxEndRange
#endif
  !
#if defined(_OPENACC)
  istat = cudaMemPrefetchAsync(zc, size(zc), mydev, 0)
  istat = cudaMemPrefetchAsync(zf, size(zf), mydev, 0)
  istat = cudaMemPrefetchAsync(dzc, size(dzc), mydev, 0)
  istat = cudaMemPrefetchAsync(dzf, size(dzf), mydev, 0)
#endif
  !
  if(myid.eq.0) then
    open(99,file=trim(datadir)//'grid.bin',access='direct',recl=4*ng(3)*sizeof(1._rp))
    write(99,rec=1) dzc_g(1:ng(3)),dzf_g(1:ng(3)),zc_g(1:ng(3)),zf_g(1:ng(3))
    close(99)
    open(99,file=trim(datadir)//'grid.out')
    do kk=1-nh_d,ng(3)+nh_d
      write(99,'(5E15.7)') 1._rp*kk,zf_g(kk),zc_g(kk),dzf_g(kk),dzc_g(kk)
    enddo
    close(99)
    open(99,file=trim(datadir)//'geometry.out')
      write(99,*) ng(1),ng(2),ng(3)
      write(99,*) l(1),l(2),l(3)
    close(99)
  endif
  !$acc kernels
  do k=1-nh_d,ng(3)+nh_d
    dzfi_g(k) = 1._rp/dzf_g(k)
    dzci_g(k) = 1._rp/dzc_g(k)
  enddo
  !$acc end kernels
  !@cuf istat=cudaDeviceSynchronize()
  !
#if defined(_OPENACC)
  istat = cudaMemPrefetchAsync(dzci, size(dzci), mydev, 0)
  istat = cudaMemPrefetchAsync(dzfi, size(dzfi), mydev, 0)
  istat = cudaMemPrefetchAsync(zc, size(zc), mydev, 0)
#endif
  !
  ! compute the spacing along z in local coordinates
  !
  !$acc kernels
  do k=1-nh_d,n(3)+nh_d
    kk      = k + ijk_start(3)
    zc(k)   = zc_g(kk)
    zf(k)   = zf_g(kk)
    dzf(k)  = dzf_g(kk)
    dzc(k)  = dzc_g(kk)
    dzfi(k) = 1._rp/dzf(k)
    dzci(k) = 1._rp/dzc(k)
  enddo
  !$acc end kernels
  !@cuf istat=cudaDeviceSynchronize()
  !
  ! test input files before proceeding with the calculation
  !
  call test_sanity(ng,n,dims_xyz(:,3),ipencil,nh_d,nh_u,nh_p,halo_d,halo_u,halo_p,stop_type, &
                   cbcvel,cbcpre,bcvel,bcpre,is_outflow,is_forced,dli,dzci_g,dzfi_g)
  !
  if(.not.restart) then
    !
    istep = 0
    time  = 0._rp
    is_first_tmp = .true.
    is_first_vel = .true.
    !
#if defined(_OPENACC)
    istat = cudaMemPrefetchAsync(dzci, size(dzci), cudaCpuDeviceId, 0)
    istat = cudaMemPrefetchAsync(dzfi, size(dzfi), cudaCpuDeviceId, 0)
#endif
    !
    if(.not.late_init) then
      !
      ! Initialize VoF
      !
#if defined(_USE_NVTX)
      call nvtxStartRange('initvof')
#endif
      call initvof(n,dli,psi)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,psi)
      call alloc_vof_var(n(1),n(2),n(3))
#if defined(_USE_NVTX)
      call nvtxEndRange
#endif
      !
    endif
    !
    ! Initialize temperature
    !
#if defined(_USE_NVTX)
    call nvtxStartRange('inittmp')
#endif
    call inittmp(initmp,n(1),n(2),n(3),nh_v,nh_t,dims,.false.,0.5d0,psi,tmp)
    call boundp(cbctmp,n,bctmp,nh_d,nh_t,halo_t,dl,dzc,dzf,tmp)
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    !
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    call initflow(inivel,n(1),n(2),n(3),dims,nh_d,nh_u,nh_p,zc/lz,dzc/lz,dzf/lz,u,v,w,p)
    !
    ! set to zeros the rhs of momentum equation
    ! (only for the first time-step, not for the restarting)
    !
    !$acc kernels
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          dudtrko(i,j,k) = 0._rp
          dvdtrko(i,j,k) = 0._rp
          dwdtrko(i,j,k) = 0._rp
        enddo
      enddo
    enddo
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
    !
    ! set to zeros the rhs of temperature equation
    ! (only for the first time-step, not for the restarting)
    !
    !$acc kernels
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          dtmpdtrkold(i,j,k) = 0._rp
        enddo
      enddo
    enddo
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
    !
    if(myid.eq.0) print*, '*** Initial condition succesfully set ***'
    !
  else
    !
    action_load = 'r'
    call load(action_load,trim(datadir)//'fldu.bin',n,      u(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'fldv.bin',n,      v(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'fldw.bin',n,      w(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'flddu.bin',n,dudtrko(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'flddv.bin',n,dvdtrko(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'flddw.bin',n,dwdtrko(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'fldp.bin',n,      p(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'fldpsi.bin',n,    psi(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'fldtmp.bin',n,    tmp(1:n(1),1:n(2),1:n(3)))
    call load(action_load,trim(datadir)//'flddtmp.bin',n,dtmpdtrkold(1:n(1),1:n(2),1:n(3)))
    call load_scalar(action_load,trim(datadir)//'scalar.out',time,istep,dto)
    !
    if(myid.eq.0) print*, '*** Checkpoint loaded at time = ', time, 'time step = ', istep, '. ***'
    !
    is_first_vel = .false.
    is_first_tmp = .false.
    !
    call alloc_vof_var(n(1),n(2),n(3)) ! to put here (important for the restarting)
    !
  endif
#if defined(_OPENACC)
  istat = cudaMemPrefetchAsync(u, size(u), mydev, 0)
  istat = cudaMemPrefetchAsync(v, size(v), mydev, 0)
  istat = cudaMemPrefetchAsync(w, size(w), mydev, 0)
  istat = cudaMemPrefetchAsync(p, size(p), mydev, 0)
  istat = cudaMemPrefetchAsync(pold, size(pold), mydev, 0)
#endif
  !
  ! set boundary conditions on the initial/loaded fields
  !
  call bounduvw(cbcvel,n,bcvel,nh_d,nh_u,halo_u,is_outflow,dl,dzc,dzf,u,v,w)
  call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,p)
  call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,psi)
  call boundp(cbctmp,n,bctmp,nh_d,nh_t,halo_t,dl,dzc,dzf,tmp)
  !
  ! for the first time-step and the restarting we use a 0th order extrapolation
  ! in time-splitting of the pressure equation
  !
  !$acc kernels
  do k=1,n(3)
    do j=1,n(2)
      do i=1,n(1)
        pold(i,j,k) = p(i,j,k)
      end do
    end do
  end do
  !$acc end kernels
  !@cuf istat=cudaDeviceSynchronize()
  call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,pold)
  !
  ! update the quantities derived from VoF using the lastest available VoF field
  !
  call update_vof(n,dli,nh_d,dzc,dzf,nh_v,halo_v,psi,nor,cur_t,kappa,d_thinc)
  call update_property(n,(/rho1,rho2/),psi,rho)
  call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,rho)
  call update_property(n,(/mu1 ,mu2 /),psi,mu )
  call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,mu)
  call update_property(n,(/kappa1,kappa2/),psi,ka)
  call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,ka )
  call update_property(n,(/cp1,cp2/),psi,cpp)
  call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,cpp)
  !
  ! post-process and write initial condition
  !
  write(fldnum,'(i9.9)') istep
  include 'out1d.h90'
  include 'out2d.h90'
  include 'out3d.h90'
  !
  ! compute an initial time-step
  !
  if(.not.constant_dt) then
    call chkdt(n(1),n(2),n(3),dxi,dyi,dzi,nh_d,nh_u,dzci,dzfi,u,v,w,dtmax)
    dt = cfl*dtmax
  else
    if(myid.eq.0) print*, 'the simulation is run at constant time-step'
    dtmax = dt_input
    dt    = dtmax
  endif
  if(istep.eq.0) dto = dt
  if(myid.eq.0) print*, 'dtmax = ', dtmax, 'dt = ', dt
  dti  = 1._rp/dt
  kill = .false.
  !
  ! preliminary checks
  !
  vof_min = minval(psi(1:n(1),1:n(2),1:n(3)))
  call mpi_allreduce(MPI_IN_PLACE,vof_min,1,MPI_REAL_RP,MPI_MIN,MPI_COMM_WORLD,ierr)
  vof_max = maxval(psi(1:n(1),1:n(2),1:n(3)))
  call mpi_allreduce(MPI_IN_PLACE,vof_max,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
  vol_p1  = sum(psi(1:n(1),1:n(2),1:n(3)))*dl(1)*dl(2)*dl(3)
  call mpi_allreduce(MPI_IN_PLACE,vol_p1 ,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
  !
  var(:) = 0._rp
  var(1) = 1._rp*istep
  var(2) = dt
  var(3) = time
  var(4) = vof_min
  var(5) = vof_max
  var(6) = vol_p1
  call out0d(trim(datadir)//'vof_info.out',6,var)
  !
  ! initialize Poisson solver
  ! and deallocate global arrays (not needed anymore)
  !
  call initsolver(n,dims,dims_xyz(:,3),dli,nh_d,dzci_g,dzfi_g,cbcpre,bcpre(:,:),(/'c','c','c'/),lambdaxyp, &
                  ap,bp,cp,arrplanp,normfftp,rhsbp%x,rhsbp%y,rhsbp%z)
  deallocate(dzc_g,dzf_g,zc_g,zf_g,dzci_g,dzfi_g)
  !
  ! main loop
  !
  if(myid.eq.0) print*, '*** Calculation loop starts now ***'
  is_done = .false.
  !
  do while(.not.is_done)
    !
#if defined(_TIMING)
    dt12  = MPI_WTIME()
#endif
    !
    istep = istep + 1
    time  = time + dt
    !
    if(myid.eq.0) print*, 'Timestep #', istep, 'Time = ', time
    !
    if(late_init.and.(istep.eq.i_late_init)) then
      !
      call initvof(n,dli,psi)
      call update_vof(n,dli,nh_d,dzc,dzf,nh_v,halo_v,psi,nor,cur_t,kappa,d_thinc)
      call alloc_vof_var(n(1),n(2),n(3))
      !
      call update_property(n,(/mu1 ,mu2 /),psi,mu )
      call update_property(n,(/rho1,rho2/),psi,rho)
      call update_property(n,(/kappa1,kappa2/),psi,ka)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,mu )
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,rho)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,ka )
      call chkdt(n(1),n(2),n(3),dxi,dyi,dzi,nh_d,nh_u,dzci,dzfi,u,v,w,dtmax)
      !
    endif
    !
    ! 0. save quantities from the previous time-step
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(p,pold,pp)
#endif
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          pp(i,j,k)   = (1._rp+(dt/dto))*p(i,j,k) - (dt/dto)*pold(i,j,k)
          pold(i,j,k) = p(i,j,k)
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,pp  )
    call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,pold)
    !
    ! 1. VoF advection and properties update --> vof^(n+1)
    !
    if((.not.late_init).or.        &              ! Normal run (initialized at i=0)
       (late_init.and.istep.ge.i_late_init)) then ! in case we want first to run without advecting the VoF

      !
#if defined(_USE_NVTX)
      call nvtxStartRange("FullVof")
#endif
      call advvof(n,dli,dt,halo_v,nh_d,nh_u,dzc,dzf,u,v,w,psi,nor,cur_t,kappa,d_thinc)
      !
      call update_property(n,(/mu1 ,mu2 /),psi,mu )
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,mu )
      call update_property(n,(/rho1,rho2/),psi,rho)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,rho)
      call update_property(n,(/kappa1,kappa2/),psi,ka)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,ka )
      call update_property(n,(/cp1,cp2/),psi,cpp)
      call boundp(cbcvof,n,bcvof,nh_d,nh_v,halo_v,dl,dzc,dzf,cpp)
#if defined(_USE_NVTX)
      call nvtxEndRange
#endif
      !
    endif
    !
    ! 2. Temperature advection and thermodynamic pressure --> tmp^(n+1)
    !
#if defined(_USE_NVTX)
    call nvtxStartRange("ab2_tmp")
#endif
    call ab2_tmp(is_first_tmp,n(1),n(2),n(3),dli(1),dli(2),dli(3),nh_d,nh_t,dt,dto,rho,cpp,ka,u,v,w, &
                 tmp,dtmpdtrk,dtmpdtrkold)
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    call boundp(cbctmp,n,bctmp,nh_d,nh_t,halo_t,dl,dzc,dzf,tmp)
    !
#if !defined(_VOF_DBG)
    !
    ! 3. two-fluid Navier-Stokes --> (u,v,w,p)^(n+1)
    !
    rho0i = 1._rp/rho0
    dpdl_c(1:3) = 0._rp
    !
#if defined(_USE_NVTX)
    call nvtxStartRange("rk")
#endif
    call rk(is_first_vel,n(1),n(2),n(3),dims,dxi,dyi,dzi,nh_d,nh_u,dt,dto,rho0i,dzci,dzfi,u,v,w,p,pp, &
            kappa,psi,mu,rho, &
#if defined(_BOUSSINESQ)
            nh_t,tmp,&
#endif
            dudtrko,dvdtrko,dwdtrko,up,vp,wp,f)
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    call bounduvw(cbcvel,n,bcvel,nh_d,nh_up,halo_up,no_outflow,dl,dzc,dzf,up,vp,wp)
    dpdl_c(1:3) = dpdl_c(1:3) + f(1:3) + dpdl(1:3)*dt
    !
#if defined(_USE_NVTX)
    call nvtxStartRange("fillps")
#endif
    call fillps(n(1),n(2),n(3),nh_d,nh_up,dxi,dyi,dzi,dzci,dzfi,dti,rho0,up,vp,wp,p)
    !
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    !
    call updt_rhs_b(n(1),n(2),n(3),(/'c','c','c'/),cbcpre,nh_p,rhsbp%x,rhsbp%y,rhsbp%z,p)
#if defined(_USE_NVTX)
    call nvtxStartRange("solver")
#endif
    !
#if defined(_OPENACC)
    call solver(n_z,dims_xyz(:,3),arrplanp,normfftp,lambdaxyp,ap,bp,cp,cbcpre(:,:),(/'c','c','c'/),p)
#else
    call solver_cpu(n,arrplanp,normfftp,lambdaxyp,ap,bp,cp,cbcpre(:,3),(/'c','c','c'/),p)
#endif
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,p)
#if defined(_USE_NVTX)
    call nvtxStartRange("CorrecEcc")
#endif
    !
    call correc(n(1),n(2),n(3),nh_d,nh_u,dxi,dyi,dzi,dzci,dt,rho0,p,up,vp,wp,rho,u,v,w)
    call bounduvw(cbcvel,n,bcvel,nh_d,nh_u,halo_u,is_outflow,dl,dzc,dzf,u,v,w)
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP WORKSHARE
#endif
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          p(i,j,k) = pold(i,j,k) + p(i,j,k)
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END WORKSHARE
#endif
    call boundp(cbcpre,n,bcpre,nh_d,nh_p,halo_p,dl,dzc,dzf,p)
    !
#if defined(_USE_NVTX)
    call nvtxEndRange
#endif
    !
#endif
    !
    write(fldnum,'(i9.9)') istep
    !
    !include 'dropcheck.h90'
    !
    ! post-processing
    !
#if defined(_DO_POSTPROC)
    !
    if((mod(istep,wall_deltai).eq.0).and.do_wall) then
      call wall_avg(avg_dir,n(1),n(2),n(3),ng(1),ng(2),ng(3),dli(1),dli(2),dli(3),nh_t,ka,tmp,time)
    endif
    !
    if((mod(istep,time_deltai).eq.0).and.do_avg) then
      if(.not.allocated(vorx)) then ! allocate if this was not done before
        allocate(vorx( n(1),n(2),n(3)) , &
                 uv( n(1),n(2),n(3))   , &
                 vw( n(1),n(2),n(3))   , &
                 wu( n(1),n(2),n(3))   , &
                 utmp( n(1),n(2),n(3)) , &
                 vtmp( n(1),n(2),n(3)) , &
                 wtmp( n(1),n(2),n(3)) )
        if(    avg_dir.eq.1) then
         include 'allocation_x.h90'
        elseif(avg_dir.eq.2) then
         include 'allocation_y.h90'
        else
         include 'allocation_z.h90'
        endif
      endif
      i_av = i_av + 1
      call compute_vorticity(n(1),n(2),n(3),dli(1),dli(2),dli(3),nh_u,v,w,vorx)
      call mixed_variables(n(1),n(2),n(3),dli(1),dli(2),dli(3),nh_u,nh_t,u,v,w,tmp, &
                           utmp,vtmp,wtmp,uv,vw,wu)
     include 'time_averaging_liquid.h90'
     include 'time_averaging_gas.h90'
     include 'time_averaging_heat_transfer.h90'
    endif
    !
#endif
    !
    ! check simulation stopping criteria
    !
    if(stop_type(1)) then ! maximum number of time steps reached
      if(istep.ge.nstep   ) is_done = is_done.or..true.
    endif
    if(stop_type(2)) then ! maximum simulation time reached
      if(time .ge.time_max) is_done = is_done.or..true.
    endif
    if(stop_type(3)) then ! maximum wall-clock time reached
      tw = (MPI_WTIME()-twi)/3600._rp
      if(tw   .ge.tw_max  ) is_done = is_done.or..true.
    endif
    !
    ! check time-step size and velocity divergence
    !
    dto = dt
    if(mod(istep,icheck).eq.0) then
      !
      if(myid.eq.0) print*, 'Checking stability and divergence...'
      !
      if(.not.constant_dt) then
        if(myid.eq.0) print*, 'updating the time-step size ...'
        call chkdt(n(1),n(2),n(3),dxi,dyi,dzi,nh_d,nh_u,dzci,dzfi,u,v,w,dtmax)
        dt = cfl*dtmax
      else
        dtmax = dt_input
        dt    = dtmax
      endif
      !
      if(myid.eq.0) print*, 'dtmax = ', dtmax, 'dt = ',dt
      if(dtmax.lt.small) then
        if(myid.eq.0) print*, 'ERROR: timestep is too small.'
        if(myid.eq.0) print*, 'Aborting...'
        is_done = .true.
        kill = .true.
      endif
      dti = 1._rp/dt
      !
      if(myid.eq.0) print*, 'checking the velocity divergence ...'
      call chkdiv(n(1),n(2),n(3),dxi,dyi,dzi,nh_d,nh_u,dzfi,u,v,w,divtot,divmax)
      !
    endif
    !
    ! output routines below
    !
    if(mod(istep,iout0d).eq.0) then
      !
      var(:) = 0._rp
      var(1) = 1._rp*istep
      var(2) = dt
      var(3) = time
      call out0d(trim(datadir)//'time.out',3,var)
      !
      vof_min = minval(psi(1:n(1),1:n(2),1:n(3)))
      call mpi_allreduce(MPI_IN_PLACE,vof_min,1,MPI_REAL_RP,MPI_MIN,MPI_COMM_WORLD,ierr)
      vof_max = maxval(psi(1:n(1),1:n(2),1:n(3)))
      call mpi_allreduce(MPI_IN_PLACE,vof_max,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
      vol_p1  = sum(psi(1:n(1),1:n(2),1:n(3)))*dl(1)*dl(2)*dl(3)
      call mpi_allreduce(MPI_IN_PLACE,vol_p1 ,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      !
      var(:) = 0._rp
      var(1) = 1._rp*istep
      var(2) = dt
      var(3) = time
      var(4) = vof_min
      var(5) = vof_max
      var(6) = vol_p1
      call out0d(trim(datadir)//'vof_info.out',6,var)
      !
      if(any(is_forced(:)).or.(abs(sum(dpdl_c)).ge.small)) then ! control strategy: constant flow-rate
        call chkmean(n(1),n(2),n(3),dims,nh_d,nh_up,1._rp/(dzfi*lz),u,meanvelu)
        call chkmean(n(1),n(2),n(3),dims,nh_d,nh_up,1._rp/(dzfi*lz),v,meanvelv)
        call chkmean(n(1),n(2),n(3),dims,nh_d,nh_up,1._rp/(dzfi*lz),w,meanvelw)
        var(:)   = 0._rp
        var(1)   = time
        var(2)   = 1._rp*istep
        var(3:5) = -dpdl_c(1:3)*dti*rho2
        var(6)   = sqrt(maxval(abs(var(3:5)))*lz*0.5_rp)
        var(7)   = rho2*var(6)*0.5_rp*lz/mu2 ! Re_tau
        var(8)   = meanvelu
        var(9)   = meanvelv
        var(10)  = meanvelw
        call out0d(trim(datadir)//'forcing.out',10,var)
      endif

      !
    endif
    !
    if(mod(istep,iout1d).eq.0) then
     include 'out1d.h90'
    endif
    if(mod(istep,iout2d).eq.0) then
     include 'out2d.h90'
    endif
    if(mod(istep,iout3d).eq.0) then
     include 'out3d.h90'
    endif
    !
    if(mod(istep,isave).eq.0.or.(is_done.and..not.kill)) then
      !
      action_load = 'w'
      !
      inquire(file='data/fldu.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldu.bin   data/fldu_old.bin')
      inquire(file='data/fldv.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldv.bin   data/fldv_old.bin')
      inquire(file='data/fldw.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldw.bin   data/fldw_old.bin')
      inquire(file='data/flddu.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/flddu.bin  data/flddu_old.bin')
      inquire(file='data/flddv.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/flddv.bin  data/flddv_old.bin')
      inquire(file='data/flddw.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/flddw.bin  data/flddw_old.bin')
      inquire(file='data/flddp.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldp.bin   data/fldp_old.bin')
      inquire(file='data/fldpsi.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldpsi.bin data/fldpsi_old.bin')
      inquire(file='data/fldtmp.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/fldtmp.bin data/fldtmp_old.bin')
      inquire(file='data/flddtmp.bin', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/flddtmp.bin data/flddtmp_old.bin')
      inquire(file='data/scalar.out', exist=is_data)
      if(myid.eq.0.and.is_data) call execute_command_line('mv data/scalar.out data/scalar_old.out')
      !
      call load(action_load,trim(datadir)//'fldu.bin',n,      u(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'fldv.bin',n,      v(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'fldw.bin',n,      w(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'flddu.bin',n,dudtrko(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'flddv.bin',n,dvdtrko(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'flddw.bin',n,dwdtrko(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'fldp.bin',n,      p(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'fldpsi.bin',n,    psi(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'fldtmp.bin',n,    tmp(1:n(1),1:n(2),1:n(3)))
      call load(action_load,trim(datadir)//'flddtmp.bin',n,dtmpdtrkold(1:n(1),1:n(2),1:n(3)))
      call load_scalar(action_load,trim(datadir)//'scalar.out',time,istep,dto)
      !
      if(myid.eq.0) print*, '*** Checkpoint saved at time = ', time, 'time step = ', istep, '. ***'
      !
    endif
    !
#if defined(_TIMING)
    dt12 = MPI_WTIME()-dt12
    call MPI_ALLREDUCE(dt12,dt12av ,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(dt12,dt12min,1,MPI_REAL_RP,MPI_MIN,MPI_COMM_WORLD,ierr)
    call MPI_ALLREDUCE(dt12,dt12max,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
    !
    var(:) = 0._rp
    var(1) = 1._rp*istep
    var(2) = time
    var(3) = dt12av/(1._rp*product(dims))
    var(4) = dt12min
    var(5) = dt12max
    call out0d(trim(datadir)//'performance.out',5,var)
#endif
    !
  enddo
  !
  ! clear ffts
  !
  call fftend(arrplanp)
  !
  ! deallocate memory
  !
  deallocate(u,v,w,p,up,vp,wp,pp, &
             pold, &
             psi,kappa,mu,rho, &
             tmp,ka,cpp,dtmpdtrk,dtmpdtrkold, &
             cur_t, &
             nor, &
             d_thinc, &
             dzc,dzf,zc,zf,dzci,dzfi, &
             dudtrko,dvdtrko,dwdtrko)
#if defined(_DO_POSTPROC)
  deallocate(vorx,uv,vw,wu,utmp,vtmp,wtmp, &
             u_avg_g,v_avg_g,w_avg_g,      &
             u_avg_l,v_avg_l,w_avg_l,      &
             u_sqr_g,v_sqr_g,w_sqr_g,      &
             u_sqr_l,v_sqr_l,w_sqr_l,      &
             tmp_avg_g,tmp_sqr_g,          &
             tmp_avg_l,tmp_sqr_l,          &
             utmp_avg_g,utmp_sqr_g,        &
             utmp_avg_l,utmp_sqr_l,        &
             vtmp_avg_g,vtmp_sqr_g,        &
             vtmp_avg_l,vtmp_sqr_l,        &
             wtmp_avg_g,wtmp_sqr_g,        &
             wtmp_avg_l,wtmp_sqr_l,        &
             uv_avg_g,vw_avg_g,wu_avg_g,   &
             uv_avg_l,vw_avg_l,wu_avg_l,   &
             uv_sqr_g,vw_sqr_g,wu_sqr_g,   &
             uv_sqr_l,vw_sqr_l,wu_sqr_l,   &
             void_avg,void_sqr,            &
             vorx_avg_g,vorx_sqr_g,        &
             vorx_avg_l,vorx_sqr_l)
#endif
  !
  deallocate(lambdaxyp)
  deallocate(ap,bp,cp)
  deallocate(rhsbp%x,rhsbp%y,rhsbp%z)
  !
  if(myid.eq.0.and.(.not.kill)) print*, '*** Fim ***'
  !
  call decomp_2d_finalize
  call MPI_FINALIZE(ierr)
  call exit
  !
end program flutas


c************************************************************************
c
c      Calculation at T,P
c
c******************************************************************************
c
       SUBROUTINE SJTP(NAMAX,NSMAX,NIW,NRW,NSW,
     ;         ATOM,CHEM,IW,RW,SW,KINIT)
c
c      Calculates  properties at given T,P.
c------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NAMAX       maximum number of atoms
c @        NSMAX       maximum number of species
c @        NIW         dimension  work array IW
c @        NRW         dimension of work array IR
c @        NSW         dimension of work array IS
c @        ATOM(I)     CHARACTER*2 name of Ith atom
c @        CHEM(J)     CHARACTER*8 name of Jth species
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c          SW(I)       REAL*4 work array
c @        KINIT       initialization control
c                     1 full initialization
c                     2 start with the last values if T,P are
c                       sufficiently close to their previous values
c                     3 start with the last values
c                     4 use mols and element potentials but recalculate
c                         mol fractions (final mixed phase calculation)
c
c      Variables in the integer work array IW:
c #        IB(K)       Kth independent atom
c #        KERR        error flag
c @        KFRZ      0 not frozen or constrained
c                    1 constrained equilibrium, only specified total mols
c                    2 constrained equilibrium, general linear constraints
c                    3 constrained equilibrium at specified T,P,H
c                   -1 composition frozen, phases at same T
c                   -2 composition frozen, phases at different T
c #        KTRE        SJEQLB pass counter
c @        NA          number of atom types
c #        NB          number of bases
c @        NP          number of phases
c @        NS          number of species
c @        NSP(M)      number of species in phase M
c
c      Variables in the real work array RW:
c @        CVCJ        Joules/cal
c @        DCS(J)      density of the Jth species, g/cm*3  (0 for gas)
c @        DHF0(J)     enthalpy of form. of Jth species at 298.15K, kcal/m
c #        ELAM(K)     element potential for kth independent atom
c #        H           mixture enthalpy, J/kg
c @        P           pressure, Pa
c #        PATM        Pa/atm
c #        PMOL(M)     mols of the Mth phase
c #        S           mixture entropy, J/kg-K
c #        SMOL(J)     mols of Jth species
c @        T           temperature, K
c @        TP(M)       temperature of Mth phase, K
c #        U           mixture internal energy, J/kg
c #        V           mixture volume m^3/kg
c #        WM          mixture molal mass, g/mol
c @        WMS(J)      molal mass of Jth species, g/mol
c #        X(J)        phase mol fraction of jth species
c #        XM(J)       mixture mol fraction of jth species
c #        YM(J)       mixture mass fraction of the Jth species
c-----------------------------------------------------------------------
       IMPLICIT    REAL*8      (A-H,O-Z)
       REAL*4      SW
       CHARACTER*2 ATOM
       CHARACTER*8 CHEM
c----------------------------------------------------------------------------
       DIMENSION   ATOM(NAMAX),CHEM(NAMAX),IW(NIW),RW(NRW),SW(NSW),
     ;   IEPTR(80)
c----------------------------------------------------------------------------
       COMMON /SJEPTR/ IEPTR
       COMMON /SJTPTR/
     ;   IoKFRZ,IoCVCJ,IoPATM,IoRGAS,IoP,IoT,IoH,IoS,IoU,IoV,
     ;   IoWM,IoTP,IoDCS,IoDHF0,IoWMS,IoHMH0,IoS0,IoWMP,IoXM,IoYM
       EQUIVALENCE (IoIB,IEPTR(9)),(IoKERR,IEPTR(1)),
     ;   (IoKTRE,IEPTR(3)),(IoKUMO,IEPTR(4)),(IoNA,IEPTR(5)),
     ;   (IoNB,IEPTR(6)),(IoNP,IEPTR(7)),(IoNS,IEPTR(8)),
     ;   (IoNSP,IEPTR(30)),(IoELAM,IEPTR(39)),(IoHUGE,IEPTR(32)),
     ;   (IoPMOL,IEPTR(62)),(IoSMOL,IEPTR(74)),(IoX,IEPTR(77))
c----------------------------------------------------------------------------
       IF (KCALL.EQ.0)  THEN
           TOLD = 0
           POLD = 0
           DTMAX = 50
           PRMAX = .5
           KCALL = 1
           ENDIF
       ZERO = 0
       TINY = 1/RW(IoHUGE)
c
c    get parameters
       NA = IW(IoNA)
       NP = IW(IoNP)
       NS = IW(IoNS)
c
c   set counter
      IW(IoKTRE) = 0
c
c -- compute constants
c
       RLP = RW(IoRGAS)*DLOG(RW(IoP)/RW(IoPATM))
c
c -- get species properties
c
c    check for different phase temperatures
       L = - 2
       IF (IW(IoKFRZ).EQ.L)  THEN
c            different temperatures; set a non-displayable temperature
               RW(IoT) = RW(IoHUGE)
           ELSE
c            set phase temperatures = T
               DO 3 M=1,NP
                   RW(IoTP+M) = RW(IoT)
3                  CONTINUE
           ENDIF
c
       CALL SJTPRP(NSMAX,NIW,NRW,NSW,CHEM,IW,RW,SW)
c
c -- check for frozen composition
c
       IF (IW(IoKFRZ).LT.0) THEN
c        frozen; get phase mols and mol fractions
           CALL SJIPMX(NSMAX,NIW,NRW,CHEM,IW,RW)
           NB = NA
           IW(IoNB) = NB
           DO 9 K=1,NB
c            set basis atoms
               IW(IoIB+K) = K
c            set to show stars at printout
               RW(IoELAM+K) = RW(IoHUGE)
9              CONTINUE
           GOTO 60
           ENDIF
c
c  -- check for final mixed-phase calculation
c
       IF (KINIT.EQ.4)  THEN
c        recalculate phase mols and mol fractions from mols
           CALL SJIPMX(NSMAX,NIW,NRW,CHEM,IW,RW)
           GOTO 60
           ENDIF
c
c -- equilibrium computation
c
       GOTO (10,20,30)  KINIT
c
c    set to initialize equilibrium solution
10     KIN = 1
       GOTO 50
c
c   decide if close enough to skip initialization
20     IF (DABS(RW(IoT)-TOLD).GT.DTMAX)  GOTO 10
       IF (DABS((RW(IoP)-POLD)/RW(IoP)).GT.PRMAX)  GOTO 10
c
c    initialize with the last phase mols and mol fractions
30     K = 1
c    estimate element potentials
       CALL SJIESL(NSMAX,NIW,NRW,CHEM,IW,RW,K,DUMMY,IDUMMY)
c    rare species problem probable if error
       IF (IW(IoKERR).NE.0)  THEN
           IW(IoKERR) = 4
           RETURN
           ENDIF
       KIN = 0
c
c    make the equilibrium calculation
50     CALL SJEQLB(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW,KIN)
       IF (IW(IoKERR).NE.0)  RETURN
c
c -- compute the mols, mixture mass fractions and mol fractions
c      and the molal masses of each phase
c
60     TMASS = 0
       TMOL = 0
       J2 = 0
       DO 63 M=1,NP
           J1 = J2 + 1
           J2 = J2 + IW(IoNSP+M)
           PMASS = 0
           DO 61 J=J1,J2
               RW(IoSMOL+J) = RW(IoX+J)*RW(IoPMOL+M)
               RW(IoYM+J) = RW(IoSMOL+J)*RW(IoWMS+J)
               PMASS = PMASS + RW(IoYM+J)
61             CONTINUE
           TMOL = TMOL + RW(IoPMOL+M)
           TMASS = TMASS + PMASS
           IF (RW(IoPMOL+M).GT.ZERO)  THEN
                   RW(IoWMP+M) = PMASS/RW(IoPMOL+M)
               ELSE
                   RW(IoWMP+M) = 0
               ENDIF
63         CONTINUE
       IF ((TMASS.LE.ZERO).OR.(TMOL.LE.ZERO))  THEN
           IW(IoKERR) = 1
           RETURN
           ENDIF
       DO 65 J=1,NS
           RW(IoYM+J) = RW(IoYM+J)/TMASS
           RW(IoXM+J) = RW(IoSMOL+J)/TMOL
65         CONTINUE
       RW(IoWM) = TMASS/TMOL
c
c -- mixture property calculation
c
       RW(IoH) = 0
       RW(IoS) = 0
       RW(IoV) = 0
       J2 = 0
       DO 79 M=1,NP
           J1 = J2 + 1
           J2 = J2 + IW(IoNSP+M)
           DO 77 J=J1,J2
c            get H and S at T and 1 atm
               HX = RW(IoHMH0+J) + RW(IoDHF0+J)
               SX = RW(IoS0+J)
c            correct entropy for mol fraction
               IF (RW(IoX+J).GT.TINY)
     ;           SX = SX - RW(IoRGAS)*DLOG(RW(IoX+J))
c            check species type
               IF (RW(IoDCS+J).EQ.ZERO)  THEN
c                    gas; correct entropy for pressure
                       SX = SX - RLP
c                    calculate partial molal volume,  m**3/mol
                       VX = RW(IoRGAS)*RW(IoCVCJ)*RW(IoTP+M)/RW(IoP)
                   ELSE
c                    condensed species; correct enthalpy for pressure
                      HX = HX +
     ;                 (RW(IoP) - RW(IoPATM))*1.0E-9*RW(IoWMS+J)/
     ;                                    (RW(IoDCS+J)*RW(IoCVCJ))
c                     calculate partial molal volume,  m**3/mol
                      VX = RW(IoWMS+J)*1.0E-6/RW(IoDCS+J)
                   ENDIF
               RW(IoH) = RW(IoH) + RW(IoSMOL+J)*HX
               RW(IoS) = RW(IoS) + RW(IoSMOL+J)*SX
               RW(IoV) = RW(IoV) + RW(IoSMOL+J)*VX
77             CONTINUE
79         CONTINUE
c
c    here H is in kcal, S is in cal, and V is in m**3
c    convert to J/kg, J/kg-K, and m**3/kg, the basic SI units
c
       RW(IoH) = RW(IoH)*RW(IoCVCJ)*1.E6/TMASS
       RW(IoS) = RW(IoS)*RW(IoCVCJ)*1.E3/TMASS
       RW(IoV) = RW(IoV)*1000./TMASS
c
c    compute U, J/kg
       RW(IoU) = RW(IoH) - RW(IoP)*RW(IoV)
c
c    save last  T and P
       TOLD = RW(IoT)
       POLD = RW(IoP)
c
c    exit
       IW(IoKERR) = 0
       RETURN
c
       END
c**************************************************************************