SUBROUTINE LATGEN(NAT)
  !
  !     LATGEN GENERATES TWO BRAVAIS MATRICES, DEFINES THE VOLUME OF
  !     THE UNIT CELL AND CALLS ROTDEF
  !     BR1(3,3)  : TRANSFORMS INTEGER RECIPROCAL LATTICE VECTORS AS
  !                 GIVEN IN THE VECTORLIST OF LAPW1  ( GENERATED IN
  !                 COORS, TRANSFORMED IN BASISO, AND WRITTEN OUT IN
  !                 WFTAPE) INTO CARTESIAN SYSTEM
  !     BR2(3,3) :  TRANSFORMS A RECIPROCAL LATTICE VECTOR OF A SPE-
  !                 CIAL COORDINATE SYSTEM ( IN UNITS OF 2 PI / A )
  !                 TO CARTESIAN SYSTEM
  !
  USE param,     ONLY: nsym
  use structure, ONLY: alpha, pia, lattic, BR1, BR2, aa, bb, cc, mult, natm, ortho, pos, rotij, tauij, vol
  USE sym2,      ONLY: iz, tau, iord, init_sym2
  USE com_mpi,   ONLY: myrank, master
  !IMPLICIT REAL*8 (A-H,O-Z)
  IMPLICIT NONE
  INTEGER, intent(in) :: nat
  ! locals
  REAL*8  :: pi, cosab, cosac, cosbc, sinab, sinbc, sqrt3, wurzel, rvfac
  INTEGER :: i, j, j1, j2
  !---------------------------------------------------------------------
  !
  PI=ACOS(-1.0D0)
  SQRT3=SQRT(3.D0)
  ALPHA(1)=ALPHA(1)*PI/180.0D0
  ALPHA(2)=ALPHA(2)*PI/180.0D0
  ALPHA(3)=ALPHA(3)*PI/180.0D0
  PIA(1)=2.D0*PI/AA
  PIA(2)=2.D0*PI/BB
  PIA(3)=2.D0*PI/CC

  SELECT CASE (LATTIC(1:1))
  CASE ('H')  !.....HEXAGONAL LATTICE
     BR1(1,1)=2.D0/SQRT3*PIA(1)
     BR1(1,2)=1.D0/SQRT3*PIA(1)
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,3)=PIA(3)
     !
     BR2(1,1)=2.D0/SQRT3*PIA(1)
     BR2(1,2)=1.D0/SQRT3*PIA(1)
     BR2(1,3)=0.0D0
     BR2(2,1)=0.0D0
     BR2(2,2)=PIA(2)
     BR2(2,3)=0.0D0
     BR2(3,1)=0.0D0
     BR2(3,2)=0.0D0
     BR2(3,3)=PIA(3)
     !
     RVFAC=2.D0/SQRT(3.D0)
     ORTHO=.FALSE.
  CASE ('S', 'P')    !.....PRIMITIVE LATTICE
     SINBC=SIN(ALPHA(1))
     COSAB=COS(ALPHA(3))
     COSAC=COS(ALPHA(2))
     COSBC=COS(ALPHA(1))
     WURZEL=SQRT(SINBC**2-COSAC**2-COSAB**2+2*COSBC*COSAC*COSAB)
     BR2(1,1)= SINBC/WURZEL*PIA(1)
     BR2(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
     BR2(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
     BR2(2,1)= 0.0
     BR2(2,2)= PIA(2)/SINBC
     BR2(2,3)= -PIA(3)*COSBC/SINBC
     BR2(3,1)= 0.0
     BR2(3,2)= 0.0
     BR2(3,3)= PIA(3)
     !
     BR1(1,1)= SINBC/WURZEL*PIA(1)
     BR1(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
     BR1(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
     BR1(2,1)= 0.0
     BR1(2,2)= PIA(2)/SINBC
     BR1(2,3)= -PIA(3)*COSBC/SINBC
     BR1(3,1)= 0.0
     BR1(3,2)= 0.0
     BR1(3,3)= PIA(3)
     !
     RVFAC= 1.d0/WURZEL
     ORTHO=.TRUE.
     if(abs(alpha(1)-pi/2.d0).gt.0.0001) ortho=.false.
     if(abs(alpha(2)-pi/2.d0).gt.0.0001) ortho=.false.
     if(abs(alpha(3)-pi/2.d0).gt.0.0001) ortho=.false.
  CASE ('F')  !.....FC LATTICE
     BR1(1,1)=PIA(1)
     BR1(1,2)=0.0D0
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,3)=PIA(3)
     !     definitions according to column, rows convention for BR2
     BR2(1,1)=-PIA(1)
     BR2(1,2)= PIA(1)
     BR2(1,3)= PIA(1)
     BR2(2,1)= PIA(2)
     BR2(2,2)=-PIA(2)
     BR2(2,3)= PIA(2)
     BR2(3,1)= PIA(3)
     BR2(3,2)= PIA(3)
     BR2(3,3)=-PIA(3)
     !
     RVFAC=4.D0
     ORTHO=.TRUE.
  CASE ('B')  !.....BC LATTICE
     BR1(1,1)=PIA(1)
     BR1(1,2)=0.0D0
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,3)=PIA(3)
     !
     BR2(1,1)= 0.0D0
     BR2(1,2)= PIA(1)
     BR2(1,3)= PIA(1)
     BR2(2,1)= PIA(2)
     BR2(2,2)= 0.0D0
     BR2(2,3)= PIA(2)
     BR2(3,1)= PIA(3)
     BR2(3,2)= PIA(3)
     BR2(3,3)= 0.0D0
     !
     RVFAC=2.D0
     ORTHO=.TRUE.
  CASE ('R')   !.....RHOMBOHEDRAL LATTICE
     BR1(1,1)=1.D0/SQRT(3.D0)*PIA(1)
     BR1(1,2)=1.D0/SQRT(3.D0)*PIA(1)
     BR1(1,3)=-2.d0/sqrt(3.d0)*PIA(1)
     BR1(2,1)=-1.0d0*PIA(2)
     BR1(2,2)=1.0d0*PIA(2)
     BR1(2,3)=0.0d0*PIA(2)
     BR1(3,1)=1.0d0*PIA(3)
     BR1(3,2)=1.0d0*PIA(3)
     BR1(3,3)=1.0d0*PIA(3)
     !
     BR2(1,1)=1.D0/SQRT(3.D0)*PIA(1)
     BR2(1,2)=1.D0/SQRT(3.D0)*PIA(1)
     BR2(1,3)=-2.d0/sqrt(3.d0)*PIA(1)
     BR2(2,1)=-1.0d0*PIA(2)
     BR2(2,2)=1.0d0*PIA(2)
     BR2(2,3)=0.0d0*PIA(2)
     BR2(3,1)=1.0d0*PIA(3)
     BR2(3,2)=1.0d0*PIA(3)
     BR2(3,3)=1.0d0*PIA(3)
     RVFAC=6.D0/SQRT(3.D0)
     ORTHO=.FALSE.
  CASE ('C')
     IF(LATTIC(2:3).EQ.'XY') then !.....CXY ORTHOROMBIC CASE
        BR1(1,1)=PIA(1)
        BR1(1,2)=0.0D0
        BR1(1,3)=0.0D0
        BR1(2,1)=0.0D0
        BR1(2,2)=PIA(2)
        BR1(2,3)=0.0D0
        BR1(3,1)=0.0D0
        BR1(3,2)=0.0D0
        BR1(3,3)=PIA(3)
        !
        BR2(1,1)= PIA(1)
        BR2(1,2)= PIA(1)
        BR2(1,3)= 0.0D0
        BR2(2,1)=-PIA(2)
        BR2(2,2)= PIA(2)
        BR2(2,3)= 0.0D0
        BR2(3,1)= 0.0D0
        BR2(3,2)= 0.0D0
        BR2(3,3)= PIA(3)
        !
        RVFAC=2.D0
        ORTHO=.TRUE.
     ELSE IF(LATTIC(2:3).EQ.'YZ') then !.....CYZ ORTHOROMBIC
        BR1(1,1)=PIA(1)
        BR1(1,2)=0.0D0
        BR1(1,3)=0.0D0
        BR1(2,1)=0.0D0
        BR1(2,2)=PIA(2)
        BR1(2,3)=0.0D0
        BR1(3,1)=0.0D0
        BR1(3,2)=0.0D0
        BR1(3,3)=PIA(3)
        !
        BR2(1,1)= PIA(1)
        BR2(1,2)= 0.0
        BR2(1,3)= 0.0
        BR2(2,1)= 0.0
        BR2(2,2)= PIA(2)
        BR2(2,3)= PIA(2)
        BR2(3,1)= 0.0
        BR2(3,2)=-PIA(3)
        BR2(3,3)= PIA(3)
        !
        RVFAC=2.0
        ORTHO=.TRUE.
     ELSE IF(LATTIC(2:3).EQ.'XZ') then !.....CXZ ORTHOROMBIC OR MONOCLINIC CASE
        IF(ABS(ALPHA(3)-PI/2.0D0).LT.0.0001) then ! ORTHOROMBIC
           BR1(1,1)=PIA(1)
           BR1(1,2)=0.0D0
           BR1(1,3)=0.0D0
           BR1(2,1)=0.0D0
           BR1(2,2)=PIA(2)
           BR1(2,3)=0.0D0
           BR1(3,1)=0.0D0
           BR1(3,2)=0.0D0
           BR1(3,3)=PIA(3)
           !
           BR2(1,1)= PIA(1)
           BR2(1,2)= 0.0
           BR2(1,3)= PIA(1)
           BR2(2,1)= 0.0
           BR2(2,2)= PIA(2)
           BR2(2,3)= 0.0
           BR2(3,1)=-PIA(3)
           BR2(3,2)= 0.0
           BR2(3,3)= PIA(3)
           !
           RVFAC=2.0
           ORTHO=.TRUE.
        ELSE                     !.....CXZ MONOCLINIC CASE
           !         write(*,*) '  gamma not equal 90'
           SINAB=SIN(ALPHA(3))
           COSAB=COS(ALPHA(3))
           !
           BR1(1,1)= PIA(1)/SINAB
           BR1(1,2)= -PIA(2)*COSAB/SINAB
           BR1(1,3)= 0.0
           BR1(2,1)= 0.0
           BR1(2,2)= PIA(2)
           BR1(2,3)= 0.0
           BR1(3,1)= 0.0
           BR1(3,2)= 0.0
           BR1(3,3)= PIA(3)
           !
           BR2(1,1)= PIA(1)/SINAB
           BR2(1,2)= -PIA(2)*COSAB/SINAB
           BR2(1,3)= PIA(1)/SINAB
           BR2(2,1)= 0.0
           BR2(2,2)= PIA(2)
           BR2(2,3)= 0.0
           BR2(3,1)=-PIA(3)
           BR2(3,2)= 0.0
           BR2(3,3)= PIA(3)
           !
           RVFAC=2.0/SINAB
           ORTHO=.FALSE.
        ENDIF
     ELSE
        GOTO 900 !        Error: wrong lattice, stop execution
     ENDIF
  CASE DEFAULT
     !        Error: wrong lattice, stop execution
     GOTO 900
  END SELECT

  if (myrank.EQ.master) then
     write(6,*)' BR1,  BR2'
     do i=1,3
        write(6,654)(br1(i,j),j=1,3),(br2(i,j),j=1,3)
     enddo
  endif

  VOL=AA*BB*CC/RVFAC
  !
  !.....DEFINE ROTATION MATRICES IN NONSYMMORPHIC CASE
  !      CALL ROTDEF (NAT)
  READ(20,'(i4)') IORD
  nsym=iord
  CALL init_sym2(nsym)
  DO  J=1,IORD
     READ(20,11) ( (iz(J1,J2,J),J1=1,3),TAU(J2,J), J2=1,3 )
  enddo

  CALL ROTDEF(iz,tau,iord,nat,pos,natm,rotij,tauij,mult,lattic)
  !.....READ IN SYMMETRY OPERATIONS AND NONPRIMITIVE TRANSLATIONS
11 FORMAT(3(3I2,F11.8/))
  !
  RETURN
  !
  !        Error messages
  !
900 CALL OUTERR('LATGEN','wrong lattice.')
  STOP 'LATGEN - Error'
  !
  !        End of 'LATGEN'
  !
654 format(3f10.5,3x,3f10.5)
END SUBROUTINE LATGEN


! { dg-do run }
  integer :: a(3), h
  integer, allocatable :: c(:)
  logical :: l
  logical :: l2(3)

  h = -huge(h)
  h = h - 1
  allocate (c(3))
  a(:) = 5
  if (maxloc (a, dim = 1).ne.1) call abort
  if (maxval (a, dim = 1).ne.5) call abort
  a(2) = huge(h)
  if (maxloc (a, dim = 1).ne.2) call abort
  if (maxval (a, dim = 1).ne.huge(h)) call abort
  a(:) = h
  if (maxloc (a, dim = 1).ne.1) call abort
  if (maxval (a, dim = 1).ne.h) call abort
  a(3) = -huge(h)
  if (maxloc (a, dim = 1).ne.3) call abort
  if (maxval (a, dim = 1).ne.-huge(h)) call abort
  c(:) = 5
  if (maxloc (c, dim = 1).ne.1) call abort
  if (maxval (c, dim = 1).ne.5) call abort
  c(2) = huge(h)
  if (maxloc (c, dim = 1).ne.2) call abort
  if (maxval (c, dim = 1).ne.huge(h)) call abort
  c(:) = h
  if (maxloc (c, dim = 1).ne.1) call abort
  if (maxval (c, dim = 1).ne.h) call abort
  c(3) = -huge(h)
  if (maxloc (c, dim = 1).ne.3) call abort
  if (maxval (c, dim = 1).ne.-huge(h)) call abort
  l = .false.
  l2(:) = .false.
  a(:) = 5
  if (maxloc (a, dim = 1, mask = l).ne.0) call abort
  if (maxval (a, dim = 1, mask = l).ne.h) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
  if (maxval (a, dim = 1, mask = l2).ne.h) call abort
  a(2) = huge(h)
  if (maxloc (a, dim = 1, mask = l).ne.0) call abort
  if (maxval (a, dim = 1, mask = l).ne.h) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
  if (maxval (a, dim = 1, mask = l2).ne.h) call abort
  a(:) = h
  if (maxloc (a, dim = 1, mask = l).ne.0) call abort
  if (maxval (a, dim = 1, mask = l).ne.h) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
  if (maxval (a, dim = 1, mask = l2).ne.h) call abort
  a(3) = -huge(h)
  if (maxloc (a, dim = 1, mask = l).ne.0) call abort
  if (maxval (a, dim = 1, mask = l).ne.h) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
  if (maxval (a, dim = 1, mask = l2).ne.h) call abort
  c(:) = 5
  if (maxloc (c, dim = 1, mask = l).ne.0) call abort
  if (maxval (c, dim = 1, mask = l).ne.h) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
  if (maxval (c, dim = 1, mask = l2).ne.h) call abort
  c(2) = huge(h)
  if (maxloc (c, dim = 1, mask = l).ne.0) call abort
  if (maxval (c, dim = 1, mask = l).ne.h) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
  if (maxval (c, dim = 1, mask = l2).ne.h) call abort
  c(:) = h
  if (maxloc (c, dim = 1, mask = l).ne.0) call abort
  if (maxval (c, dim = 1, mask = l).ne.h) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
  if (maxval (c, dim = 1, mask = l2).ne.h) call abort
  c(3) = -huge(h)
  if (maxloc (c, dim = 1, mask = l).ne.0) call abort
  if (maxval (c, dim = 1, mask = l).ne.h) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
  if (maxval (c, dim = 1, mask = l2).ne.h) call abort
  l = .true.
  l2(:) = .true.
  a(:) = 5
  if (maxloc (a, dim = 1, mask = l).ne.1) call abort
  if (maxval (a, dim = 1, mask = l).ne.5) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
  if (maxval (a, dim = 1, mask = l2).ne.5) call abort
  a(2) = huge(h)
  if (maxloc (a, dim = 1, mask = l).ne.2) call abort
  if (maxval (a, dim = 1, mask = l).ne.huge(h)) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.2) call abort
  if (maxval (a, dim = 1, mask = l2).ne.huge(h)) call abort
  a(:) = h
  if (maxloc (a, dim = 1, mask = l).ne.1) call abort
  if (maxval (a, dim = 1, mask = l).ne.h) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
  if (maxval (a, dim = 1, mask = l2).ne.h) call abort
  a(3) = -huge(h)
  if (maxloc (a, dim = 1, mask = l).ne.3) call abort
  if (maxval (a, dim = 1, mask = l).ne.-huge(h)) call abort
  if (maxloc (a, dim = 1, mask = l2).ne.3) call abort
  if (maxval (a, dim = 1, mask = l2).ne.-huge(h)) call abort
  c(:) = 5
  if (maxloc (c, dim = 1, mask = l).ne.1) call abort
  if (maxval (c, dim = 1, mask = l).ne.5) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
  if (maxval (c, dim = 1, mask = l2).ne.5) call abort
  c(2) = huge(h)
  if (maxloc (c, dim = 1, mask = l).ne.2) call abort
  if (maxval (c, dim = 1, mask = l).ne.huge(h)) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.2) call abort
  if (maxval (c, dim = 1, mask = l2).ne.huge(h)) call abort
  c(:) = h
  if (maxloc (c, dim = 1, mask = l).ne.1) call abort
  if (maxval (c, dim = 1, mask = l).ne.h) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
  if (maxval (c, dim = 1, mask = l2).ne.h) call abort
  c(3) = -huge(h)
  if (maxloc (c, dim = 1, mask = l).ne.3) call abort
  if (maxval (c, dim = 1, mask = l).ne.-huge(h)) call abort
  if (maxloc (c, dim = 1, mask = l2).ne.3) call abort
  if (maxval (c, dim = 1, mask = l2).ne.-huge(h)) call abort
  deallocate (c)
  allocate (c(-2:-3))
  if (maxloc (c, dim = 1).ne.0) call abort
  if (maxval (c, dim = 1).ne.h) call abort
end


#include "macros.f90"
module IntData
    use Const

    public
    integer :: spcdim
    integer :: Nbodies
    real(mpc), dimension(:), allocatable :: m
    real(mpc) :: t0
    real(mpc) :: Period
    real(mpc) :: h
    real(mpc), dimension(:), allocatable :: p0
    real(mpc), dimension(:), allocatable :: q0

    character(*), parameter, private :: descr = '(9x)'
contains
#define skipread(fd, var) read(fd, descr, advance="no"); read(fd, *) var
    subroutine read_data(fd)
        integer, intent(in) :: fd
        skipread(fd, spcdim)
        skipread(fd, Nbodies)

        allocate(m(Nbodies))
        skipread(fd, m)

        skipread(fd, t0)
        skipread(fd, Period)
        skipread(fd, h)

        allocate(p0(Nbodies*spcdim))
        skipread(fd, p0)

        allocate(q0(Nbodies*spcdim))
        skipread(fd, q0)
    end subroutine
end module IntData


!*************************************************
!   WINDOW
!   Calculate the Spectral window-function
!   of a timeseries.
!
!   Input:
!       window [options] [inputfile] [outputfile]
!
!   Options:
!       -tday      Treat times as days (default)
!       -tsec      Treat times as seconds
!       -kplrraw   Input file is a Kepler data file (use raw columns)
!       -kplrpdc   Input file is a Kepler data file (use PDC columns)
!       -kplrwg    Input file is a Kepler data file (use WG columns)
!       -quiet     Print nothing to screen
!       -version   Print program version information
!
!   Written by
!     Rasmus Handberg
!     Department of Physics and Astronomy
!     Aarhus University
!*************************************************

program window
	use kind_defs
	use numinteg
	use timeseries
	implicit none
	real(dbl) :: nuw, dnu, dF
	real(dbl) :: nu_min, nu_max, nu
	integer :: N, j, Nspec, err
	logical :: bolUseWeights
	character(200) :: buffer, inputfile = "", outputfile = ""
	integer :: TimeType = 1 ! Default time type is days
	integer :: inputtype = 0
	real(dbl) :: t1, t2, Psum, Pint, omegaw
	real(dbl), allocatable :: win(:), fs(:), fc(:)
	integer :: nargs, iargc

	! Extract parameters from command-line:
	nargs = iargc()
	do j = 1,nargs
		call getarg(j, buffer)
		select case (trim(buffer))
			case ("-tsec")
				TimeType = 0
			case ("-tday")
				TimeType = 1
			case ("-kplrraw")
				TimeType = 1
				inputtype = 1
			case ("-kplrpdc")
				TimeType = 1
				inputtype = 2
			case ("-kplrwg")
				TimeType = 1
				inputtype = 3
			case ("-quiet")
				quiet = .true.
			case ("-version")
				print *, "Current version:"
				print *, "$Revision: 119 $"
				print *, "$Date: 2016-02-09 09:57:56 +0100 (ti, 09 feb 2016) $"
				stop
			case default
				if (.not. buffer(1:1) == "-" .and. inputfile == "") then
					inputfile = trim(buffer)
				elseif (.not. buffer(1:1) == "-" .and. outputfile == "") then
					outputfile = trim(buffer)
				else
					print *, "UNKNOWN ARGUMENT: " // trim(buffer)
					stop
				endif
		end select
	enddo

	if (.not. quiet) then
		print *, "--------------------------------"
		print *, "            WINDOW              "
		print *, "   Calculate window-function    "
		print *, "--------------------------------"
	endif

	! If no files were given, ask for input and make output:
    if (inputfile == '') then
        print *, 'Enter input-file:'
        read '(a50)', inputfile
    endif
	if (outputfile == '') then
		j = scan(inputfile, '/', back=.true.)
		if (j /= 0) then
			outputfile = trim(inputfile(j+1:))
		else
			outputfile = trim(inputfile)
		endif
		j = scan(outputfile, '.', back=.true.)
		if (j > 1) then
			outputfile = trim(outputfile(1:j-1)) // '.window'
		else
			outputfile = trim(outputfile) // '.window'
		endif
	endif

	! Import data:
	if (.not. quiet) then
		print *, "Reading data..."
    endif
    open(50, file=inputfile, status='old', action='read')
        ! New count:
        call CountData(50, N, bolUseWeights, inputtype)
        ! Allocate the data:
    	allocate(t(1:N), f(1:N), w(1:N), fs(1:N), fc(1:N), stat=err)
    	if (err /= 0) stop "Couldn''t allocate memory!"
    	! Ask to use the statistical weights:
		if (bolUseWeights) then
			print *, "Do you want to use the statistical weights? (1=yes,0=no)"
			read(*, '(i1)') j
			if (j == 0) bolUseWeights = .false.
		endif
		if (.not. quiet) then
			if (bolUseWeights) then
				print *, "Using weights"
			else
				print *, "Not using weights"
			endif
		endif
        ! Import the data:
        call ImportData(50, bolUseWeights, t, f, w, inputtype)
    close(50)

    ! Convert time vector to seconds, based on the selected input:
    if (TimeType == 1) then
    	t = t*86400_dbl
    endif

    ! Print information about series:
	call print_info(t)

	! Frequencies to calculate the window for:
	print *, ""
	print *, "Windowfunction Frequency (microHz):"
	read *, nuw
	print *, "Frequency interval (microHz):"
	read *, dnu
	print *, "Frequency resolution (microHz):"
	read *, dF
	print *, ""

	! A bit of frequency-calculations:
	call cpu_time(t1)
	nu_min = nuw - dnu
	Nspec = ceiling(dnu/dF)
	if (Nspec <= 0 .or. dnu <= 0 .or. nu_min < 0) stop "Wrong frequencies!"

	! Allocate space for windowfunction:
	allocate(win(1:(2*Nspec+1)), stat=err)
	if (err /= 0) stop "Couldn't allocate memory!"

	! Calculate fake datasets:
	omegaw = pi*nuw*2e-6_dbl
	fs(:) = w(:)*sin(omegaw*t(:)) ! Sine-function "dataset"
	fc(:) = w(:)*cos(omegaw*t(:)) ! Cosine-function "dataset"

	! Write the windowfunction to the outputfile:
	if (.not. quiet) then
		print *, "--------------------------------"
	endif
	!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(nu,j) SCHEDULE(STATIC)
	do j = -Nspec,Nspec
		nu = nuw+j*dF

		win(Nspec+1+j) = windowfunction(t, w, nuw, nu, fs, fc)

		call Progress2(2*Nspec+1)
	enddo
	!$OMP END PARALLEL DO

	! Calculate sum and integral of window:
	if (.not. quiet) then
		Psum = sum(win)
		Pint = simpson(dF, win)
		print *, ''
		print *, "--------------------------------"
		print *, 'Psum = ', Psum
		print *, 'Pint = ', Pint
    endif

	! Write spectrum to file:
    open(51, file=outputfile, status='replace', action='write')
	write(51, '(a)') '#-----------------------------------------'
	write(51, '(a)') '# WINDOW'
	write(51, '(a)') '# ' // trim(inputfile)
	write(51, '(a,f8.2,a)') '# Window frequency: ', nuw, ' microHz'
	write(51, '(a,f6.4,a)') '# Resolution: ', dF, ' microHz'
	write(51, '(a)') '# Frequencies in microHz, Window (power)'
	write(51, '(a)') '#-----------------------------------------'
    do j = -Nspec,Nspec
    	nu = j*dF
        write(51, '(f17.10,ES26.16E3)') nu, win(Nspec+1+j)
    enddo
    close(51)

	! Clean the memory:
	deallocate(t,f,w,win,fs,fc)

	call cpu_time(t2)
    call print_time(t2-t1)
end program window


! queue_system.f90 --
!     Simulate a queueing system:
!     One queue, three booths at which the client is served
!     The booths handle a client and ask for the next one
!
!     Clients take some handling time:
!     33% take 1 minutes
!     33% take 2 minutes
!     33% take 5 minutes
!
module queue_events
    use events_library

    implicit none

    type, extends(basic_event) :: queue_event
        integer :: arrival_time   = -1   ! Time of arrival of the client
        integer :: handling_time  = -1   ! Time the client requires for handling their request
    end type queue_event

end module queue_events

program queue_system
    use queue_events
    implicit none

    type(basic_event_stack)         :: list_events
    class(queue_event), allocatable :: event
    class(basic_event), allocatable :: event_popped

    type booth_data
        integer :: clients_handled = 0
        integer :: idle_time       = 0
        integer :: current_time    = 0
    end type booth_data

    type(booth_data), dimension(3) :: booth

    integer                 :: i
    integer                 :: j
    integer, dimension(1)   :: loc
    real                    :: r
    integer                 :: number, average_number
    integer                 :: time, handling_time
    integer                 :: waiting_time
    integer                 :: cnt

    !
    ! Set up the queue: on average N clients per hour
    ! Their arrival is arbitrary over the hour
    ! There are eight working hours.
    !
    average_number = 20
    waiting_time   = 0

    allocate( event )

    !
    ! Random numbers are not always so random, unfortunately, use a
    ! naive procedure to get some randomness between runs even if a
    ! plain "call random_seed" does not provide this functionality.
    !
    call system_clock( cnt )
    call random_seed

    do i = 1,8
        do j = 1,mod(cnt,1000)
            call random_number( r )
        enddo
        number = 2.0 * r * average_number

        !
        ! Distribute them over the hour
        !
        do j = 1,number
            call random_number( r )
            time = (i-1) * 3600 + 60 * r

            call random_number( r )
            if ( r < 1.0/3.0 ) then
                handling_time = 60
            elseif ( r < 2.0/3.0 ) then
                handling_time = 180
            else
                handling_time = 300
            endif

            event%arrival_time  = time
            event%handling_time = handling_time

            call list_events%push( event )
        enddo
    enddo

    !
    ! Now we have three booths, as long as there are clients
    ! they need to be handled
    !
    number = list_events%number()

    do i = 1,number
        time = minval(booth%current_time)
        loc  = minloc(booth%current_time)
        j    = loc(1)

        call list_events%pop_plain( event_popped ) ! Get them in time order

        !
        ! Some trickery is required, it seems
        !
        select type (event_popped)
             class is (queue_event)
                 !call move_alloc( event, event_popped ) -- strange error message: event_popped shall be allocatable?
                 if ( allocated(event) ) then
                     deallocate( event )
                 endif
                 allocate( event, source = event_popped )
        end select
        !
        ! We have a client, handle them:
        ! - If the client arrived later than the ready time for the booth,
        !   the booth was idle.
        ! - Otherwise the client had to wait
        !
        if ( booth(j)%current_time < event%arrival_time ) then
            booth(j)%idle_time    = booth(j)%idle_time    + (event%arrival_time - booth(j)%current_time)
            booth(j)%current_time = event%arrival_time    + event%handling_time
        else
            waiting_time          = waiting_time          + (booth(j)%current_time - event%arrival_time)
            booth(j)%current_time = booth(j)%current_time + event%handling_time
        endif

        booth(j)%clients_handled = booth(j)%clients_handled + 1

!        write(*,*) j, booth(j)
!
!        if ( i > 4 ) then
!            exit
!        endif
    enddo

    !
    ! Output
    !
    write(*,'(a,i0)') 'Number of clients:  ', number
    write(*,'(a,i0)') 'Total waiting time: ', waiting_time
    do j = 1,size(booth)
        write(*,'(a,i0)') 'Booth ', j
        write(*,'(a,i0)') '    Number of clients: ', booth(j)%clients_handled
        write(*,'(a,i0)') '    Idle time:         ', booth(j)%idle_time
    enddo

end program queue_system


program prop
!! Show:
!! * %re and %im properties of real number in Fortran 2018
!! * %len property of character

use, intrinsic :: iso_fortran_env, only: real32
implicit none (type, external)

character(:), allocatable :: c
complex :: z

z = (1, 1.414)
c = 'hello'
c = 'hi'

print *, c, c%len
if (c%len /= len(c)) error stop 'character %len'

print *, z%re, z%im, z%kind
if (real32 /= z%kind) error stop 'kind mismatch'

end program


       SUBROUTINE W3FB01(XI,XJ,XMESHL,ALAT,ALONG)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB01         I,J TO LATITUDE, LONGITUDE
C   AUTHOR: HEERMANN,A.      ORG: W345       DATE: 69-08-01
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION FROM THE GRID(I,J)
C   COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PRO-
C   JECTION TRUE AT 60 N TO THE NATURAL COORDINATE SYSTEM OF LATITUDE
C   /LONGITUDE ON THE EARTH. A PREFERABLE MORE FLEXIBLE SUBROUTINE TO
C   USE IS W3FB05. W3FB01 IS THE REVERSE OF W3FB00.
C
C PROGRAM HISTORY LOG:
C   69-08-01  A. HEERMANN
C   90-08-31  R.E.JONES     CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB01 (XI, XJ, XMESHL, ALAT, ALONG)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  I OF THE POINT RELATIVE TO NORTH POLE
C     XJ     ARG LIST  J OF THE POINT RELATIVE TO NORTH POLE
C     XMESHL ARG LIST  MESH LENGTH OF GRID IN KILOMETERS AT 60N
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALAT   ARG LIST  LATITUDE IN DEG. (-20.0(S. HEMIS) < ALAT < 90.0)
C     ALONG  ARG LIST  WEST LONGITUDE IN DEGREES
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ASIN ATAN2                                              SYSLIB
C
C   REMARKS: THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0)
C     AT THE NORTH POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A
C     POINT OTHER THAN THE NORTH POLE, A TRANSLATION IS REQUIRED TO
C     GET I AND J FOR INPUT INTO W3FB01. THE SUBROUTINE GRID IS
C     ORIENTED SO THAT LONGITUDE 80W IS PARALLEL TO GRIDLINES OF
C     I=CONSTANT. THE EARTH'S RADIUS IS TAKEN TO BE 6371.2 KM.
C     ALL PARAMETERS IN THE CALL STATEMENT MUST BE REAL
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      DATA  DEGPRD/57.2957795/
      DATA  EARTHR/6371.2/
C
      GI2 = (1.86603 * EARTHR) / XMESHL
      GI2 = GI2 * GI2
      R2  = XI * XI + XJ * XJ
      IF (R2.NE.0.0)  GO TO 100
      ALONG = 0.0
      ALAT = 90.0
      RETURN
C
100   CONTINUE
      ALAT = ASIN((GI2-R2) / (GI2+R2)) * DEGPRD
      XLONG = DEGPRD * ATAN2(XJ,XI)
      IF (XLONG) 200,300,300
C
200   CONTINUE
      ALONG = -10.0 - XLONG
      IF (ALONG.LT.0.0)  ALONG = ALONG + 360.0
      GO TO 400
C
300   CONTINUE
      ALONG = 350.0 - XLONG
C
400   CONTINUE
      RETURN
        END


subroutine nbody_rk4
! This subroutine drives the N-Body integration over a single timestep
! Integration is done in a separate set of arrays for speed
! Orbital elements are stored in GE_embryo type

! Do integration

use stardata,only: debug
use embryodata

implicit none

integer :: ibody
logical :: withintolerance

withintolerance = .false.
if(debug=='y') print*, 'Attempting integration RK4'

do while(withintolerance .eqv. .false.)

newpos(:,:) = 0.0
newvel(:,:) = 0.0

! Switch off velocities of finished particles
do ibody=2,nbodies
   if(embryo(ibody-1)%finished==1) vel(:,ibody)=0.0
enddo

call nbody_integrate(dt_nbody,pos,vel,newpos,newvel)
call nbody_timestep(newpos,newvel)

if(maxerror<tolerance) withintolerance=.true.

end do

pos = newpos
vel = newvel

call nbody_system_properties

end subroutine nbody_rk4


!*==cgels.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  CGELS solves overdetermined or underdetermined systems for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGELS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
!                         INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGELS solves overdetermined or underdetermined complex linear systems
!> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
!> or LQ factorization of A.  It is assumed that A has full rank.
!>
!> The following options are provided:
!>
!> 1. If TRANS = 'N' and m >= n:  find the least squares solution of
!>    an overdetermined system, i.e., solve the least squares problem
!>                 minimize || B - A*X ||.
!>
!> 2. If TRANS = 'N' and m < n:  find the minimum norm solution of
!>    an underdetermined system A * X = B.
!>
!> 3. If TRANS = 'C' and m >= n:  find the minimum norm solution of
!>    an underdetermined system A**H * X = B.
!>
!> 4. If TRANS = 'C' and m < n:  find the least squares solution of
!>    an overdetermined system, i.e., solve the least squares problem
!>                 minimize || B - A**H * X ||.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!> matrix X.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          = 'N': the linear system involves A;
!>          = 'C': the linear system involves A**H.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of
!>          columns of the matrices B and X. NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>            if M >= N, A is overwritten by details of its QR
!>                       factorization as returned by CGEQRF;
!>            if M <  N, A is overwritten by details of its LQ
!>                       factorization as returned by CGELQF.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the matrix B of right hand side vectors, stored
!>          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
!>          if TRANS = 'C'.
!>          On exit, if INFO = 0, B is overwritten by the solution
!>          vectors, stored columnwise:
!>          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
!>          squares solution vectors; the residual sum of squares for the
!>          solution in each column is given by the sum of squares of the
!>          modulus of elements N+1 to M in that column;
!>          if TRANS = 'N' and m < n, rows 1 to N of B contain the
!>          minimum norm solution vectors;
!>          if TRANS = 'C' and m >= n, rows 1 to M of B contain the
!>          minimum norm solution vectors;
!>          if TRANS = 'C' and m < n, rows 1 to M of B contain the
!>          least squares solution vectors; the residual sum of squares
!>          for the solution in each column is given by the sum of
!>          squares of the modulus of elements M+1 to N in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= MAX(1,M,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= max( 1, MN + max( MN, NRHS ) ).
!>          For optimal performance,
!>          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
!>          where MN = min(M,N) and NB is the optimum block size.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO =  i, the i-th diagonal element of the
!>                triangular factor of A is zero, so that A does not have
!>                full rank; the least squares solution could not be
!>                computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGEsolve
!
!  =====================================================================
      SUBROUTINE CGELS(Trans,M,N,Nrhs,A,Lda,B,Ldb,Work,Lwork,Info)
      IMPLICIT NONE
!*--CGELS185
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , B(Ldb,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
      COMPLEX CZERO
      PARAMETER (CZERO=(0.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , tpsd
      INTEGER brow , i , iascl , ibscl , j , mn , nb , scllen , wsize
      REAL anrm , bignum , bnrm , smlnum
!     ..
!     .. Local Arrays ..
      REAL rwork(1)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL CLANGE , SLAMCH
      EXTERNAL LSAME , ILAENV , CLANGE , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL CGELQF , CGEQRF , CLASCL , CLASET , CTRTRS , CUNMLQ ,    &
     &         CUNMQR , SLABAD , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , REAL
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      Info = 0
      mn = MIN(M,N)
      lquery = (Lwork==-1)
      IF ( .NOT.(LSAME(Trans,'N') .OR. LSAME(Trans,'C')) ) THEN
         Info = -1
      ELSEIF ( M<0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Nrhs<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -6
      ELSEIF ( Ldb<MAX(1,M,N) ) THEN
         Info = -8
      ELSEIF ( Lwork<MAX(1,mn+MAX(mn,Nrhs)) .AND. .NOT.lquery ) THEN
         Info = -10
      ENDIF
!
!     Figure out optimal block size
!
      IF ( Info==0 .OR. Info==-10 ) THEN
!
         tpsd = .TRUE.
         IF ( LSAME(Trans,'N') ) tpsd = .FALSE.
!
         IF ( M>=N ) THEN
            nb = ILAENV(1,'CGEQRF',' ',M,N,-1,-1)
            IF ( tpsd ) THEN
               nb = MAX(nb,ILAENV(1,'CUNMQR','LN',M,Nrhs,N,-1))
            ELSE
               nb = MAX(nb,ILAENV(1,'CUNMQR','LC',M,Nrhs,N,-1))
            ENDIF
         ELSE
            nb = ILAENV(1,'CGELQF',' ',M,N,-1,-1)
            IF ( tpsd ) THEN
               nb = MAX(nb,ILAENV(1,'CUNMLQ','LC',N,Nrhs,M,-1))
            ELSE
               nb = MAX(nb,ILAENV(1,'CUNMLQ','LN',N,Nrhs,M,-1))
            ENDIF
         ENDIF
!
         wsize = MAX(1,mn+MAX(mn,Nrhs)*nb)
         Work(1) = REAL(wsize)
!
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGELS ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N,Nrhs)==0 ) THEN
         CALL CLASET('Full',MAX(M,N),Nrhs,CZERO,CZERO,B,Ldb)
         RETURN
      ENDIF
!
!     Get machine parameters
!
      smlnum = SLAMCH('S')/SLAMCH('P')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
!
!     Scale A, B if max element outside range [SMLNUM,BIGNUM]
!
      anrm = CLANGE('M',M,N,A,Lda,rwork)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL CLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL CLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL CLASET('F',MAX(M,N),Nrhs,CZERO,CZERO,B,Ldb)
         GOTO 100
      ENDIF
!
      brow = M
      IF ( tpsd ) brow = N
      bnrm = CLANGE('M',brow,Nrhs,B,Ldb,rwork)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL CLASCL('G',0,0,bnrm,smlnum,brow,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL CLASCL('G',0,0,bnrm,bignum,brow,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
      IF ( M>=N ) THEN
!
!        compute QR factorization of A
!
         CALL CGEQRF(M,N,A,Lda,Work(1),Work(mn+1),Lwork-mn,Info)
!
!        workspace at least N, optimally N*NB
!
         IF ( .NOT.tpsd ) THEN
!
!           Least-Squares Problem min || A * X - B ||
!
!           B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS)
!
            CALL CUNMQR('Left','Conjugate transpose',M,Nrhs,N,A,Lda,    &
     &                  Work(1),B,Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
!
            CALL CTRTRS('Upper','No transpose','Non-unit',N,Nrhs,A,Lda, &
     &                  B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
            scllen = N
!
         ELSE
!
!           Underdetermined system of equations A**T * X = B
!
!           B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS)
!
            CALL CTRTRS('Upper','Conjugate transpose','Non-unit',N,Nrhs,&
     &                  A,Lda,B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
!           B(N+1:M,1:NRHS) = ZERO
!
            DO j = 1 , Nrhs
               DO i = N + 1 , M
                  B(i,j) = CZERO
               ENDDO
            ENDDO
!
!           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
!
            CALL CUNMQR('Left','No transpose',M,Nrhs,N,A,Lda,Work(1),B, &
     &                  Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
            scllen = M
!
         ENDIF
!
      ELSE
!
!        Compute LQ factorization of A
!
         CALL CGELQF(M,N,A,Lda,Work(1),Work(mn+1),Lwork-mn,Info)
!
!        workspace at least M, optimally M*NB.
!
         IF ( .NOT.tpsd ) THEN
!
!           underdetermined system of equations A * X = B
!
!           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
!
            CALL CTRTRS('Lower','No transpose','Non-unit',M,Nrhs,A,Lda, &
     &                  B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
!           B(M+1:N,1:NRHS) = 0
!
            DO j = 1 , Nrhs
               DO i = M + 1 , N
                  B(i,j) = CZERO
               ENDDO
            ENDDO
!
!           B(1:N,1:NRHS) := Q(1:N,:)**H * B(1:M,1:NRHS)
!
            CALL CUNMLQ('Left','Conjugate transpose',N,Nrhs,M,A,Lda,    &
     &                  Work(1),B,Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
            scllen = N
!
         ELSE
!
!           overdetermined system min || A**H * X - B ||
!
!           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
!
            CALL CUNMLQ('Left','No transpose',N,Nrhs,M,A,Lda,Work(1),B, &
     &                  Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:M,1:NRHS) := inv(L**H) * B(1:M,1:NRHS)
!
            CALL CTRTRS('Lower','Conjugate transpose','Non-unit',M,Nrhs,&
     &                  A,Lda,B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
            scllen = M
!
         ENDIF
!
      ENDIF
!
!     Undo scaling
!
      IF ( iascl==1 ) THEN
         CALL CLASCL('G',0,0,anrm,smlnum,scllen,Nrhs,B,Ldb,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL CLASCL('G',0,0,anrm,bignum,scllen,Nrhs,B,Ldb,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL CLASCL('G',0,0,smlnum,bnrm,scllen,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL CLASCL('G',0,0,bignum,bnrm,scllen,Nrhs,B,Ldb,Info)
      ENDIF
!
 100  Work(1) = REAL(wsize)
!
!
!     End of CGELS
!
      END SUBROUTINE CGELS


module mod_correc

  use mod_param
  use mod_common

  implicit none

  private
  public correc

contains
  !
  ! Corrects the velocity so that it is divergence free
  !
  subroutine correc(p)

    real, intent(in), dimension(0:,0:,0:) :: p
    real, dimension(0:i1,0:j1,0:k1) :: dpdx, dpdy, dpdz
    integer :: i,j,k

    !$omp parallel default(none) &
    !$omp&shared(factori,factorj,factork) &
    !$omp&shared(p,unew,vnew,wnew,dudt,dvdt,dwdt) &
    !$omp&private(i,j,k)
    !$omp do

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

             !---- Remove pressure jump (GFM) ----!

             unew(i,j,k) = dudt(i,j,k) - dt*dxi * ( p(i+1,j,k)-p(i,j,k) -p_x(i,j,k) )/rho0
             vnew(i,j,k) = dvdt(i,j,k) - dt*dyi * ( p(i,j+1,k)-p(i,j,k) -p_y(i,j,k) )/rho0
             wnew(i,j,k) = dwdt(i,j,k) - dt*dzi * ( p(i,j,k+1)-p(i,j,k) -p_z(i,j,k) )/rho0

          enddo
       enddo
    enddo
    !$omp end parallel

    return
  end subroutine correc

end module mod_correc


      SUBROUTINE slDPSC (XI, ETA, RA, DEC, RAZ1, DECZ1,
     :                                         RAZ2, DECZ2, N)
*+
*     - - - - - - -
*      D P S C
*     - - - - - - -
*
*  From the tangent plane coordinates of a star of known RA,Dec,
*  determine the RA,Dec of the tangent point.
*
*  (double precision)
*
*  Given:
*     XI,ETA      d    tangent plane rectangular coordinates
*     RA,DEC      d    spherical coordinates
*
*  Returned:
*     RAZ1,DECZ1  d    spherical coordinates of tangent point, solution 1
*     RAZ2,DECZ2  d    spherical coordinates of tangent point, solution 2
*     N           i    number of solutions:
*                        0 = no solutions returned (note 2)
*                        1 = only the first solution is useful (note 3)
*                        2 = both solutions are useful (note 3)
*
*  Notes:
*
*  1  The RAZ1 and RAZ2 values are returned in the range 0-2pi.
*
*  2  Cases where there is no solution can only arise near the poles.
*     For example, it is clearly impossible for a star at the pole
*     itself to have a non-zero XI value, and hence it is
*     meaningless to ask where the tangent point would have to be
*     to bring about this combination of XI and DEC.
*
*  3  Also near the poles, cases can arise where there are two useful
*     solutions.  The argument N indicates whether the second of the
*     two solutions returned is useful.  N=1 indicates only one useful
*     solution, the usual case;  under these circumstances, the second
*     solution corresponds to the "over-the-pole" case, and this is
*     reflected in the values of RAZ2 and DECZ2 which are returned.
*
*  4  The DECZ1 and DECZ2 values are returned in the range +/-pi, but
*     in the usual, non-pole-crossing, case, the range is +/-pi/2.
*
*  5  This routine is the spherical equivalent of the routine slDPVC.
*
*  Called:  slDA2P
*
*  P.T.Wallace   Starlink   5 June 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION XI,ETA,RA,DEC,RAZ1,DECZ1,RAZ2,DECZ2
      INTEGER N

      DOUBLE PRECISION X2,Y2,SD,CD,SDF,R2,R,S,C

      DOUBLE PRECISION slDA2P

      X2=XI*XI
      Y2=ETA*ETA
      SD=SIN(DEC)
      CD=COS(DEC)
      SDF=SD*SQRT(1D0+X2+Y2)
      R2=CD*CD*(1D0+Y2)-SD*SD*X2
      IF (R2.GE.0D0) THEN
         R=SQRT(R2)
         S=SDF-ETA*R
         C=SDF*ETA+R
         IF (XI.EQ.0D0.AND.R.EQ.0D0) R=1D0
         RAZ1=slDA2P(RA-ATAN2(XI,R))
         DECZ1=ATAN2(S,C)
         R=-R
         S=SDF-ETA*R
         C=SDF*ETA+R
         RAZ2=slDA2P(RA-ATAN2(XI,R))
         DECZ2=ATAN2(S,C)
         IF (ABS(SDF).LT.1D0) THEN
            N=1
         ELSE
            N=2
         END IF
      ELSE
         N=0
      END IF

      END


SUBROUTINE GaussSeidel(x,b,SMCSR)
! By Allan P. Engsig-Karup.
! FIXME: always do free surface first??
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: nnz, nrow, Gidx, i
TYPE (SparseArray_CSR) :: SMCSR
REAL(KIND=long), DIMENSION(SMCSR%nnz), INTENT(INOUT) :: x
REAL(KIND=long), DIMENSION(SMCSR%nnz), INTENT(IN) :: b
REAL(KIND=long) :: diagcoef
nrow = SMCSR%nrow
nnz  = SMCSR%nnz
DO Gidx = 1, nrow
	i = Gidx
!	print*,'i=',i
!	print*,'SMCSR%row_ptr(i)=',SMCSR%row_ptr(i)
	diagcoef = SMCSR%val(SMCSR%row_ptr(i))
!	IF (SMCSR%row_ptr(i+1) - SMCSR%row_ptr(i) == 1) THEN
!		x(Gidx) = b(Gidx)/diagcoef
!	ELSE
		x(Gidx) = ( b(Gidx) - DOT_PRODUCT( x( SMCSR%col_ind( SMCSR%row_ptr(i)+1 : SMCSR%row_ptr(i+1)-1 ) ),&
						       SMCSR%val( SMCSR%row_ptr(i)+1 : SMCSR%row_ptr(i+1)-1 ) ) )/diagcoef
!	END IF
END DO
END SUBROUTINE GaussSeidel


!*==dgetrf.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DGETRF VARIANT: iterative version of Sivan Toledo's recursive LU algorithm
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       DOUBLE PRECISION   A( LDA, * )
!       ..
!
!  Purpose
!  =======
!
!>\details \b Purpose:
!>\verbatim
!>
!> DGETRF computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This code implements an iterative version of Sivan Toledo's recursive
!> LU algorithm[1].  For square matrices, this iterative versions should
!> be within a factor of two of the optimum number of memory transfers.
!>
!> The pattern is as follows, with the large blocks of U being updated
!> in one call to DTRSM, and the dotted lines denoting sections that
!> have had all pending permutations applied:
!>
!>  1 2 3 4 5 6 7 8
!> +-+-+---+-------+------
!> | |1|   |       |
!> |.+-+ 2 |       |
!> | | |   |       |
!> |.|.+-+-+   4   |
!> | | | |1|       |
!> | | |.+-+       |
!> | | | | |       |
!> |.|.|.|.+-+-+---+  8
!> | | | | | |1|   |
!> | | | | |.+-+ 2 |
!> | | | | | | |   |
!> | | | | |.|.+-+-+
!> | | | | | | | |1|
!> | | | | | | |.+-+
!> | | | | | | | | |
!> |.|.|.|.|.|.|.|.+-----
!> | | | | | | | | |
!>
!> The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
!> the binary expansion of the current column.  Each Schur update is
!> applied as soon as the necessary portion of U is available.
!>
!> [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
!> Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
!> 1065-1081. http://dx.doi.org/10.1137/S0895479896297744
!>
!>\endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!> \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, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U is exactly
!>                singular, and division by zero will occur if it is used
!>                to solve a system of equations.
!> \endverbatim
!>
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup variantsGEcomputational
!
!  =====================================================================
      SUBROUTINE DGETRF(M,N,A,Lda,Ipiv,Info)
      IMPLICIT NONE
!*--DGETRF138
!
!  -- LAPACK computational routine (version 3.X) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      DOUBLE PRECISION A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO , NEGONE
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
      PARAMETER (NEGONE=-1.0D+0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION sfmin , tmp
      INTEGER i , j , jp , nstep , ntopiv , npived , kahead
      INTEGER kstart , ipivstart , jpivstart , kcols
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      INTEGER IDAMAX
      LOGICAL DISNAN
      EXTERNAL DLAMCH , IDAMAX , DISNAN
!     ..
!     .. External Subroutines ..
      EXTERNAL DTRSM , DSCAL , XERBLA , DLASWP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , IAND
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGETRF',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Compute machine safe minimum
!
      sfmin = DLAMCH('S')
!
      nstep = MIN(M,N)
      DO j = 1 , nstep
         kahead = IAND(j,-j)
         kstart = j + 1 - kahead
         kcols = MIN(kahead,M-j)
!
!        Find pivot.
!
         jp = j - 1 + IDAMAX(M-j+1,A(j,j),1)
         Ipiv(j) = jp

!        Permute just this column.
         IF ( jp/=j ) THEN
            tmp = A(j,j)
            A(j,j) = A(jp,j)
            A(jp,j) = tmp
         ENDIF

!        Apply pending permutations to L
         ntopiv = 1
         ipivstart = j
         jpivstart = j - ntopiv
         DO WHILE ( ntopiv<kahead )
            CALL DLASWP(ntopiv,A(1,jpivstart),Lda,ipivstart,j,Ipiv,1)
            ipivstart = ipivstart - ntopiv
            ntopiv = ntopiv*2
            jpivstart = jpivstart - ntopiv
         ENDDO

!        Permute U block to match L
         CALL DLASWP(kcols,A(1,j+1),Lda,kstart,j,Ipiv,1)

!        Factor the current column
         IF ( A(j,j)/=ZERO .AND. .NOT.DISNAN(A(j,j)) ) THEN
            IF ( ABS(A(j,j))>=sfmin ) THEN
               CALL DSCAL(M-j,ONE/A(j,j),A(j+1,j),1)
            ELSE
               DO i = 1 , M - j
                  A(j+i,j) = A(j+i,j)/A(j,j)
               ENDDO
            ENDIF
         ELSEIF ( A(j,j)==ZERO .AND. Info==0 ) THEN
            Info = j
         ENDIF

!        Solve for U block.
         CALL DTRSM('Left','Lower','No transpose','Unit',kahead,kcols,  &
     &              ONE,A(kstart,kstart),Lda,A(kstart,j+1),Lda)
!        Schur complement.
         CALL DGEMM('No transpose','No transpose',M-j,kcols,kahead,     &
     &              NEGONE,A(j+1,kstart),Lda,A(kstart,j+1),Lda,ONE,     &
     &              A(j+1,j+1),Lda)
      ENDDO

!     Handle pivot permutations on the way out of the recursion
      npived = IAND(nstep,-nstep)
      j = nstep - npived
      DO WHILE ( j>0 )
         ntopiv = IAND(j,-j)
         CALL DLASWP(ntopiv,A(1,j-ntopiv+1),Lda,j+1,nstep,Ipiv,1)
         j = j - ntopiv
      ENDDO

!     If short and wide, handle the rest of the columns.
      IF ( M<N ) THEN
         CALL DLASWP(N-M,A(1,M+kcols+1),Lda,1,M,Ipiv,1)
         CALL DTRSM('Left','Lower','No transpose','Unit',M,N-M,ONE,A,   &
     &              Lda,A(1,M+kcols+1),Lda)
      ENDIF

!
!     End of DGETRF
!
      END SUBROUTINE DGETRF


module norm
  use, intrinsic :: iso_c_binding
  implicit none

  integer, public, parameter :: norm_infinity   = 1
  integer, public, parameter :: norm_one        = 2
  integer, public, parameter :: norm_frobenius  = 3

  integer, public, parameter :: norm_error_norm = -1
  integer, public, parameter :: norm_error_m    = -2
  integer, public, parameter :: norm_error_n    = -3
  integer, public, parameter :: norm_error_oom  = -2147483647
  contains

  function matnorm(norm, m, n, x, ret) &
  bind(c, name='matnorm')
    implicit none
    ! In/Out
    integer(kind=c_int), intent(in), value :: norm
    integer(kind=c_int), intent(in), value :: m, n
    real(kind=c_double), intent(in) :: x(m, n)
    real(kind=c_double), intent(out) :: ret
    integer(kind=c_int) :: matnorm
    ! Local
    character(len=1) :: normchar
    integer :: lwork, allocerr
    double precision :: ldx
    double precision, allocatable :: work(:)
    ! Functions
    double precision :: dlange

    ret = 0.0d0
    lwork = 0
    matnorm = 0

    if (m < 1) then
      matnorm = norm_error_m
      return
    else if (n < 1) then
      matnorm = norm_error_n
      return
    end if

    if (norm == norm_infinity) then
      normchar = "I"
    else if (norm == norm_one) then
      normchar = "O"
    else if (norm == norm_frobenius) then
      normchar = "F"
    else
      matnorm = norm_error_norm
      return
    end if

    if (normchar == "I") then
      lwork = m
      allocerr = 0
      allocate(work(lwork), stat=allocerr)
      if (allocerr /= 0) then
        matnorm = norm_error_oom
        return
      end if
    end if

    ldx = max(1, m)

    ret = dlange(normchar, m, n, x, ldx, work)

    if (allocated(work)) deallocate(work)

    return
  end

end module


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.01/05                           *
C  *    TEST TITLE : Behavior of transformation of points  *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      REAL      A4(4,4), A3(3,3), PX,PY,PZ, ACTTPX,ACTTPY,ACTTPZ
      REAL      EXPTPX,EXPTPY,EXPTPZ, ABSERR, RELERR
      LOGICAL   APPEQ

      CALL INITGL ('06.01.01/05')

C open PHIGS
      CALL XPOPPH  (ERRFIL, MEMUN)

C set up tolerance: absolute/relative error
      ABSERR = 1.0E-7
      RELERR = 1.0E-5

      CALL SETMSG ('1 2 13', '<Transform point 3> should return ' //
     1             'the 3D point resulting from applying the '    //
     2             'specified transformation matrix to the '      //
     3             'specified point.')

C set up transform
      A4(1,1) = -2.2
      A4(1,2) = 3.3
      A4(1,3) = 4.4
      A4(1,4) = 5.5
      A4(2,1) = 0.0023
      A4(2,2) = -727.12
      A4(2,3) = 2.09
      A4(2,4) = 33.33
      A4(3,1) = 0
      A4(3,2) = 34
      A4(3,3) = 54.1
      A4(3,4) = -0.045
      A4(4,1) = 7
      A4(4,2) = 6
      A4(4,3) = 5
      A4(4,4) = 4

C initialize point to be transformed
      PX = -262.27
      PY = 0.02525
      PZ = 53.838

C compute actual transformed point
      CALL PTP3  (PX,PY,PZ, A4, ERRIND, ACTTPX,ACTTPY,ACTTPZ)
      CALL CHKINQ ('ptp3', ERRIND)

C  Compute expected point
      CALL ETP3  (PX,PY,PZ, A4, EXPTPX,EXPTPY,EXPTPZ)

C Pass iff points are approximately equal
      CALL IFPF ( APPEQ(ACTTPX, EXPTPX, ABSERR, RELERR) .AND.
     1            APPEQ(ACTTPY, EXPTPY, ABSERR, RELERR) .AND.
     2            APPEQ(ACTTPZ, EXPTPZ, ABSERR, RELERR) )

      CALL SETMSG ('1 2 14', '<Transform point> should return the '  //
     1             '2D point resulting from applying the specified ' //
     2             'transformation matrix to the specified point.')

      A3(1,1) = -2.2
      A3(1,2) = 3.3
      A3(1,3) = 5.5
      A3(2,1) = 0.0023
      A3(2,2) = -727.12
      A3(2,3) = 33.33
      A3(3,1) = 0
      A3(3,2) = 34
      A3(3,3) = -0.045

C initialize point to be transformed
      PX = -262.27
      PY = 53.838

C compute actual transformed point
      CALL PTP  (PX,PY, A3, ERRIND, ACTTPX,ACTTPY)
      CALL CHKINQ ('ptp', ERRIND)

C  Compute expected point
      CALL ETP  (PX,PY, A3, EXPTPX,EXPTPY)

C Pass iff points are approximately equal
      CALL IFPF ( APPEQ(ACTTPX, EXPTPX, ABSERR, RELERR) .AND.
     1            APPEQ(ACTTPY, EXPTPY, ABSERR, RELERR) )

      CALL ENDIT
      END


module mg_define_rhs

  use mg_mpi
  use mg_grids
  use mg_mpi_exchange
  use mg_netcdf_out

  implicit none

contains
  !-------------------------------------------------------------------------
  subroutine rhs_seamount()

    integer(kind=ip):: nx,ny,nz
    integer(kind=ip):: i,j,k
    integer(kind=ip):: pi, pj
    integer(kind=ip):: npxg

    real(kind=rp) :: bet, x, x1, z1, x2, z2

    real(kind=rp), dimension(:,:,:), pointer :: rhs
    real(kind=rp), dimension(:,:,:), pointer :: zr
    real(kind=rp), dimension(:,:,:), pointer :: zw

    nx = grid(1)%nx
    ny = grid(1)%ny
    nz = grid(1)%nz

    npxg = grid(1)%npx

    pj = myrank / npxg
    pi = myrank - pj * npxg

    ! rhs definition
    bet = 600._rp / (Lx*Lx)
    x1  = Lx   *  0.65_rp
    x2  = Lx   *  0.75_rp
    z1  = Htot * (0.75_rp - 1._rp)
    z2  = Htot * (0.65_rp - 1._rp)

    rhs => grid(1)%b
    zr  => grid(1)%zr
    zw  => grid(1)%zw

    do i = 0,nx+1
       do j = 0,ny+1
          x = (real(i+(pi*nx),kind=rp)-0.5_rp) * dx(j,i)
          do k = 1,nz
             rhs(k,j,i) = dx(j,i)*dy(j,i)*(zw(k+1,j,i)-zw(k,j,i)) * &
                  (exp(-bet * ((x-x1)**2 + (zr(k,j,i)-z1)**2)) - &
                  exp(-bet * ((x-x2)**2 + (zr(k,j,i)-z2)**2)))
          enddo
       enddo
    enddo

    !!call fill_halo(1,rhs)

    if (netcdf_output) then
       call write_netcdf(grid(1)%b,vname='rhs',netcdf_file_name='rhs_seamount.nc',rank=myrank)
    endif

  end subroutine rhs_seamount

  !-------------------------------------------------------------------------
  subroutine rhs_random()

    integer(kind=ip):: nx,ny,nz
    integer(kind=ip):: i,j,k

    nx = grid(1)%nx
    ny = grid(1)%ny
    nz = grid(1)%nz

    call random_number(grid(1)%b)

    grid(1)%b = 2._rp * grid(1)%b - 1._rp

    call fill_halo(1,grid(1)%b)

    do i = 0,nx+1
       do j = 0,ny+1
          do k = 1,nz
             grid(1)%b(k,j,i) = &
                  grid(1)%dx(j,i)*grid(1)%dy(j,i)* &
                  ( grid(1)%zw(k+1,j,i) - grid(1)%zw(k,j,i) ) * grid(1)%b(k,j,i)
          enddo
       enddo
    enddo

    if (netcdf_output) then
       call write_netcdf(grid(1)%b,vname='rhs',netcdf_file_name='rhs_random.nc',rank=myrank)
    endif

  end subroutine rhs_random

  !-------------------------------------------------------------------------
  subroutine setup_random_patches()

    ! define the r.h.s. as a sum of random gaussian patches
    ! sign, width, location are random

    integer(kind=ip):: nx,ny,nz
    integer(kind=ip):: i,j,k,l
    integer(kind=ip):: npxg,npyg,pi,pj
    integer(kind=ip):: nbpatch,i0,j0,k0,sign
    real(kind=rp)   :: sigh2,sigv2,dh2,dv2,x0,y0,z0

    nbpatch = 100

    sigh2=10._rp**2
    sigv2=3._rp**2

    nx = grid(1)%nx
    ny = grid(1)%ny
    nz = grid(1)%nz

    npxg = grid(1)%npx
    npyg = grid(1)%npy
    pj = myrank/npxg
    pi = mod(myrank,npxg)

    grid(1)%b = 0._rp
    do l=1,nbpatch

       call random_number(x0)
       sign=floor(x0*2)*2-1

       call random_number(x0)
       sigh2=(x0*50)**2
       call random_number(x0)
       sigv2=(x0*20)**2

       call random_number(x0)
       call random_number(y0)
       call random_number(z0)
       ! we use the (i,j,k) global coordinates
       ! instead of (x,y,z)
       i0=1+floor(x0*npxg*nx)
       j0=1+floor(y0*npyg*ny)
       k0 = 1+floor(z0*nz)
       !!if(myrank==0)write(*,10)i0,j0,k0,sign,sqrt(sigh2),sqrt(sigv2)
       do i = 0,nx+1
          do j = 0,ny+1
             do k = 1,nz
                dh2 = 1.*(i+pi*nx-i0)**2+1.*(j+pj*ny-j0)**2
                dv2 = 1.*(k-k0)**2
                grid(1)%b(k,j,i) = grid(1)%b(k,j,i) +&
                     sign*exp( -dh2 / (2.*sigh2) -dv2/(2.*sigv2))
             enddo
          enddo
       enddo
    enddo

10  format("(i0,j0,k0) =",I5,I5,I4," - sign,sigh,sigv = ",I3,F6.1,F6.1)

    call fill_halo(1,grid(1)%b)

    if (netcdf_output) then
       call write_netcdf(grid(1)%b,vname='rhs',netcdf_file_name='rhs.nc',rank=myrank)
    endif

  end subroutine setup_random_patches

end module mg_define_rhs


program nonstd_to_c58

  integer*8 n58
  character*11 callsign
  character*38 c
  data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/

  nargs=iargc()
  if(nargs.ne.1) then
     print*,'Usage:    nonstd_to_c58 <callsign>'
     print*,'Examples: nonstd_to_c58 PJ4/K1ABC'
     print*,'          nonstd_to_c58 YW18FIFA'
     go to 999
  endif
  call getarg(1,callsign)

  n58=0
  do i=1,11
     n58=n58*38 + index(c,callsign(i:i)) - 1
  enddo
  write(*,1000) callsign,n58,n58
1000 format('Callsign: ',a11/'c58 (binary):   ' b58.58/'c58 (decimal):',i20)

999 end program nonstd_to_c58


c=======================================================================
      subroutine dpbetabinom(nrec,y,
     &                       ngrid,grid,
     &                       a0,b0,a1,b1,
     &                       ncluster,ss,alpha,p,
     &                       mcmc,nsave,
     &                       cpo,densm,thetasave,randsave,
     &                       ccluster,cstrt,prob,lprob,workcpo,
     &                       seed)
c=======================================================================
c     # of arguments = 24.
c
c     Subroutine `dpbetabinom' to run a Markov chain for a
c     semiparametric Beta-Binomial model using a DP prior.
c
c     Copyright: Alejandro Jara, 2009-2010.
c
c     Version 1.0:
c
c     Last modification: 05-07-2007.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        nrec        :  integer giving the number of data points.
c        y           :  real vector giving the transformed data, y(nrec).
c
c-----------------------------------------------------------------------
c
c---- Prediction -------------------------------------------------------
c
c        ngrid       :  integer giving the number of grid points.
c        grid        :  real vector giving the grid points, grid(ngrid).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        a0, b0      :  real giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       alpha ~ Gamma(a0,b0). If a0<0 the precision
c                       parameter is considered as a constant.
c        a1,b1       :  real giving the parameters of the Beta centering
c                       distribution.
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        ncluster    :  integer giving the number of clusters.
c        ss          :  integer vector giving the configurations.
c        alpha       :  real giving the current value of the precision
c                       parameter of the DP.
c        p           :  real vector giving the value of the binomial
c                       probabilities, p(nrec+1).
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c        nbase       :  integer giving the the number of scans where
c                       the baseline distribution and the precision
c                       parameter are sampled.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        cpo         :  real matrix giving the cpo's, cpo(nrec,2).
c        densm       :  real vector giving the posterior mean of the
c                       density estimate, densm(ngrid).
c        thetasave   :  real matrix containing the mcmc samples for
c                       k, the number of clusters and alpha,
c                       thetsave(nsave,3).
c        randsave    :  real matrix containing the mcmc samples for
c                       the latent variables and prediction,
c                       randsave(nsave,nrec+1).
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        ccluster    :  integer vector indicating the number of
c                       subjects in each cluster, ccluster(nrec).
c        cstrt       :  integer matrix used to save the cluster
c                       structure, cstrt(nrec,nrec).
c        prob        :  real vector used to update the cluster
c                       structure, prob(nrec+1).
c        lprob       :  real vector used to update the cluster
c                       structure, prob(nrec+1).
c        workcpo     :  real vector used to compute the cpo,
c                       workcpo(nrec).
c        seed        :  integer vector giving the seeds for the random
c                       number generator, seed(2).
c
c=======================================================================
      implicit none
c++++ data
      integer nrec
      real*8 y(nrec,2)

c++++ prediction
      integer ngrid
      real*8 grid(ngrid)

c++++ prior
      real*8 a0,b0
      real*8 a1,b1

c++++ current value
      integer ncluster
      integer ss(nrec)
      real*8 alpha
      real*8 p(nrec+1)

c+++++MCMC parameters
      integer mcmc(3),nburn,nskip,nsave,ndisplay

c+++++output
      real*8 cpo(nrec,2)
      real*8 densm(ngrid)
      real*8 thetasave(nsave,3)
      real*8 randsave(nsave,nrec+1)

c+++++External Working space
      integer ccluster(nrec)
      integer cstrt(nrec,nrec)
      real*8 prob(nrec+1)
      real*8 lprob(nrec+1)
      real*8 workcpo(nrec)

c+++++External Working space - RNG
      integer seed(2),seed1,seed2

c+++++Internal Working space
      integer dispcount
      integer evali
      integer i,ii,j
      integer iscan,isave
      integer ns,nscan
      integer ok
      integer since
      integer skipcount
      integer sprint
      real*8 dbin,dbet
      real*8 mbetabin
      real*8 pwork
      real*8 tmp1,tmp2,tmp3

c+++++CPU time
      real*8 sec00,sec0,sec1,sec

c++++ DP (functional parameter)
      real*8 eps,rbeta
      parameter(eps=0.01)

c++++ parameters
      nburn=mcmc(1)
      nskip=mcmc(2)
      ndisplay=mcmc(3)

c++++ set random number generator
      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c++++ cluster structure
      do i=1,nrec
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
         prob(i)=0.d0
         lprob(i)=0.d0
      end do
      pwork=0.d0

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      do iscan=1,nscan

c++++++++++++++++++++++++++++++
c+++++++ a) Polya Urn
c++++++++++++++++++++++++++++++

         do i=1,nrec

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            ns=ccluster(ss(i))

            if(ns.gt.1)then
               ccluster(ss(i))=ccluster(ss(i))-1

               j=1
               ok=0
               do while(ok.eq.0.and.j.le.ns)
                  if(cstrt(ss(i),j).eq.i)ok=j
                  j=j+1
               end do

               do j=ok,ns-1
                  cstrt(ss(i),j)=cstrt(ss(i),j+1)
               end do

             else

               since=ss(i)

               if(since.lt.ncluster)then

                  call relabeldpbetabin(i,since,nrec,ncluster,
     &                                  ccluster,ss,cstrt,p)
               end if
               ccluster(ncluster)=ccluster(ncluster)-1
               ncluster=ncluster-1
            end if

            do j=1,ncluster
               tmp2=dbin(dble(y(i,1)),dble(y(i,1)+y(i,2)),p(j),0)
               prob(j)=dble(ccluster(j))*tmp2
            end do

            tmp1=a1+dble(y(i,1))
            tmp2=b1+dble(y(i,2))
            p(ncluster+1)=rbeta(tmp1,tmp2)

            tmp1=dble(y(i,1))
            tmp2=dble(y(i,2))
            prob(ncluster+1)=alpha*exp(mbetabin(a1,b1,tmp1,tmp2))

            call simdisc(prob,nrec+1,ncluster+1,evali)

            ss(i)=evali
            ccluster(evali)=ccluster(evali)+1
            cstrt(evali,ccluster(evali))=i

            if(evali.gt.ncluster)then
               ncluster=ncluster+1
            end if

         end do

c++++++++++++++++++++++++++++++
c+++++++ b) Resampling step
c++++++++++++++++++++++++++++++

         do i=1,ncluster

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            ns=ccluster(i)
            tmp1=a1
            tmp2=b1

            do j=1,ns

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

               ii=cstrt(i,j)
               tmp1=tmp1+dble(y(ii,1))
               tmp2=tmp2+dble(y(ii,2))
            end do

            p(i)=rbeta(tmp1,tmp2)
         end do

c++++++++++++++++++++++++++++++++++
c+++++++ Precision parameter
c++++++++++++++++++++++++++++++++++
         if(a0.gt.0.d0)then
            call samalph(alpha,a0,b0,ncluster,nrec)
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ save samples
c++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

c+++++++++++++ cluster information

               thetasave(isave,1)=ncluster
               thetasave(isave,2)=alpha

c+++++++++++++ subject specific information

               do i=1,nrec
                  randsave(isave,i)=p(ss(i))
               end do

c+++++++++++++ predictive information

               do i=1,ncluster
                   prob(i)=dble(ccluster(i))/(alpha+dble(nrec))
               end do
               prob(ncluster+1)=alpha/(alpha+dble(nrec))
               call simdisc(prob,nrec+1,ncluster+1,evali)

               pwork=0.d0
               if(evali.le.ncluster)then
                  pwork=p(evali)
               end if
               if(evali.eq.ncluster+1)then
                  pwork=rbeta(a1,b1)
               end if
               randsave(isave,nrec+1)=pwork

               do i=1,ncluster
                  ns=ccluster(i)
                  tmp1=a1
                  tmp2=b1

                  do j=1,ns
                     ii=cstrt(i,j)
                     tmp1=tmp1+dble(y(ii,1))
                     tmp2=tmp2+dble(y(ii,2))
                  end do

                  do j=1,ngrid
                     densm(j)=densm(j)+
     &                        prob(i)*dbet(grid(j),tmp1,tmp2,0)
                  end do
               end do
               do j=1,ngrid
                  densm(j)=densm(j)+
     &                     prob(ncluster+1)*dbet(grid(j),a1,b1,0)
               end do

c+++++++++++++ cpo

               do i=1,nrec
                  workcpo(i)=0.d0
               end do

               do i=1,nrec
                  do j=1,ncluster
                     prob(j)=dble(ccluster(i))/(alpha+dble(nrec))
                     tmp2=dbin(dble(y(i,1)),dble(y(i,1)+y(i,2)),p(j),0)
                     workcpo(i)=workcpo(i)+prob(j)*tmp2
                  end do
                  prob(ncluster+1)=alpha/(alpha+dble(nrec))

                  tmp1=dble(y(i,1))
                  tmp2=dble(y(i,2))
                  workcpo(i)=workcpo(i)+prob(ncluster+1)*
     &                       exp(mbetabin(a1,b1,tmp1,tmp2))
               end do

               tmp2=0.d0
               do i=1,nrec
                  tmp3=workcpo(i)
                  cpo(i,1)=cpo(i,1)+1.0d0/tmp3
                  cpo(i,2)=cpo(i,2)+tmp3
                  tmp2=tmp2+log(dble(isave)/cpo(i,1))
               end do
               thetasave(isave,3)=tmp2

c               call dblepr("LPML",-1,tmp2,1)

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  tmp1=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if

      end do

      do i=1,nrec
         call rchkusr()
         cpo(i,1)=dble(nsave)/cpo(i,1)
         cpo(i,2)=cpo(i,2)/dble(nsave)
      end do

      do j=1,ngrid
         densm(j)=densm(j)/dble(nsave)
      end do

      return
      end

c=======================================================================
      subroutine relabeldpbetabin(ind,since,nrec,ncluster,ccluster,
     &                            ss,cstrt,p)
c=======================================================================
      implicit none
      integer ind,since,nrec,ncluster,ccluster(nrec)
      integer ss(nrec),cstrt(nrec,nrec)
      real*8 p(nrec+1)

      integer i,ii,j,ns
      real*8 pwork

      pwork=p(since)

      do i=since+1,ncluster
         ns=ccluster(i)

         do j=1,ns
c++++++++++ check if the user has requested an interrupt
            call rchkusr()
            ii=cstrt(i,j)
            ss(ii)=i-1
         end do
         do j=1,ns
            cstrt(i-1,j)=cstrt(i,j)
         end do
         p(i-1)=p(i)
         ccluster(i-1)=ccluster(i)
      end do

      ss(ind)=ncluster

      p(ncluster)=pwork
      ccluster(ncluster)=1

      return
      end

c=======================================================================
      double precision function mbetabin(a1,b1,x1,x2)
c=======================================================================
      implicit none
      real*8 a1,b1
      real*8 x1,x2
      real*8 dgamlog
      mbetabin=dgamlog(a1+x1)+dgamlog(b1+x2)+dgamlog(a1+b1)
      mbetabin=mbetabin-dgamlog(a1+b1+x1+x2)
      mbetabin=mbetabin-dgamlog(a1)-dgamlog(b1)
      mbetabin=mbetabin+dgamlog(x1+x2+1.d0)
      mbetabin=mbetabin-dgamlog(x1+1.d0)-dgamlog(x2+1.d0)
      return
      end

c=======================================================================
      subroutine sindidp(maxn,n,lprob,aprob,evali)
c=======================================================================
      implicit none
      integer maxn,n
      real*8 lprob(maxn),aprob(maxn)

c+++++internal working space
      integer evali

c+++++internal working space
      integer cond,i
      real*8 mmax,tmp1
      real runif

      mmax=lprob(1)
      do i=2,n
         if(lprob(i).gt.mmax) mmax=lprob(i)
      end do
      do i=1,n
         lprob(i)=dexp(lprob(i)-mmax)
      end do

      aprob(1)=lprob(1)
      do i=2,n
         aprob(i)=aprob(i-1)+lprob(i)
      enddo
      do i=1,n
         aprob(i)=aprob(i)/aprob(n)
      enddo

      tmp1=dble(runif())
      i=0
      cond=0
      do while((cond.eq.0).and.(i.le.n))
         i=i+1
         if (aprob(i).ge.tmp1) cond=1
      end do
      evali=i
      return
      end


module solve_mod

contains

    subroutine solve(ct)

        use constants
        use cycle_tower_mod
        use traverse_mod
        use v_cycle_mod
        use fmg_cycle_mod

        implicit none

        type(cycle_tower), intent(inout) :: ct

        integer :: iter, nlvl
        double precision :: res0_norm, res_norm

        nlvl = ct%nlvl

        if (ct%cycle_type == V_CYCLE_TYPE) then

            ! Calculate initial residual
            call residual(ct%res(nlvl),ct%sol,ct%rhs,ct%bb(nlvl,:),ct%dx(nlvl))
            res_norm = norm_inf(ct%res(nlvl))

            if (parallel_IOProcessor()) then
                if (ct%verbose >= 1) then
                    print *, ''
                    write(*,'(a,i4,a,es28.18)') &
                    '    Starting V-Cycle Solve at n =', ct%n(nlvl),'.  norm(residual) =', res_norm
                end if
            end if

        else if (ct%cycle_type == FMG_CYCLE_TYPE) then

            ! Calculate initial residual
            call residual(ct%ff(nlvl),ct%sol,ct%rhs,ct%bb(nlvl,:),ct%dx(nlvl))
            res_norm = norm_inf(ct%ff(nlvl))

            if (parallel_IOProcessor()) then
                if (ct%verbose >= 1) then
                    write(*,*) ''
                    write(*,'(a,i4,a,es28.18)')&
                    '    Starting FMG-Cycle Solve at n=',ct%n(nlvl),'.   norm(residual) = ', res_norm
                end if
            end if

        end if

        res0_norm = res_norm

        do iter = 1,ct%max_iter

            if (ct%cycle_type == V_CYCLE_TYPE) then

                ! Approximate solution by executing one V-cycle
                call v_cycle(ct,nlvl,nlvl)

                ! Calculate residual after V-cycle
                call residual(ct%res(nlvl),ct%sol,ct%rhs,ct%bb(nlvl,:),ct%dx(nlvl))
                res_norm = norm_inf(ct%res(nlvl))

                if (parallel_IOProcessor()) then
                    if (ct%verbose >= 1) then
                        write(*,'(a,i3,a,i4,a,es28.18)')&
                        '   ', iter,' V-Cycle(s) completed at n =',ct%n(nlvl),'.  norm(residual) =', res_norm
                    end if
                end if

            else if (ct%cycle_type == FMG_CYCLE_TYPE) then

                ! Approximate error to solution by executing one FMG-cycle
                call fmg_cycle(ct,nlvl)

                ! Calculate residual of corrected solution and set it to RHS
                call residual(ct%ff(nlvl),ct%sol,ct%rhs,ct%bb(nlvl,:),ct%dx(nlvl))
                res_norm = norm_inf(ct%ff(nlvl))

                if (parallel_IOProcessor()) then
                    if (ct%verbose > 0) then
                        write(*,'(a,i2,a,i4,a,es28.18)')&
                        '   ',iter,' FMG-Cycle(s) completed at n=',ct%n(nlvl), '.  norm(residual) = ', res_norm
                    end if
                end if

            end if

            ! Check for convergence
            if (res_norm/res0_norm < ct%eps) then
                exit
            end if

        end do

        iter = iter - 1

        if (parallel_IOProcessor()) then
            print *, ''
            print *, '******************************'
            if (ct%cycle_type == V_CYCLE_TYPE) then
                write(*,'(a,$)') ' V-Cycle'
            else if (ct%cycle_type == FMG_CYCLE_TYPE) then
                write(*,'(a,$)') ' FMG-Cycle'
            end if

            if (ct%dim == 2) then
                write(*,'(a,$)') ' (2D)'
            else if (ct%dim == 3) then
                write(*,'(a,$)') ' (3D)'
            end if

            if (ct%interp_type == LIN_INTERP) then
                write(*,'(a,$)') ', piecewise linear interpolation'
            else if (ct%interp_type == CONST_INTERP) then
                write(*,'(a,$)') ', piecewise constant interpolation'
            end if
            write(*,'(a,i4)') ', n = ', ct%n(ct%nlvl)

            write(*,'(a,i3)') ' Number of Cycles = ', iter
            write(*,'(a,es28.18)') ' Final residual = ', res_norm
            write(*,'(a,es28.18)') ' Final res/res0 =', res_norm/res0_norm
            write(*,'(a)') '******************************'
            write(*,'(a)') ''
        end if

    end subroutine solve

end module solve_mod


subroutine sort(n, a)
    implicit none
    integer :: n, i, j
    real :: a(n), x

    do i = 2, n
        x = a(i)
        j = i - 1
        do while (j >= 1)
            if (a(j) <= x) exit
            a(j + 1) = a(j)
            j = j - 1
        end do
        a(j + 1) = x
    end do
end subroutine


	subroutine compute_dzmm(zmm, lx, dzmm)
	implicit none
	integer i, lx
	double precision zmm(-5:23), dzmm(23)

	dzmm(1) = zmm(2)/2.0d0
	dzmm(2) = (zmm(3) + zmm(2))/2.0d0 - zmm(2)/2.0d0
	do i = 3, lx
         if (i /= lx) then
            dzmm(i) = (zmm(i+1) - zmm(i-1))/2.0d0 ! thickness of first layer
         else if (i == lx) then
            dzmm(i) = (zmm(i)-zmm(i-1))/2.0d0
         endif
	enddo

	end subroutine compute_dzmm


! Created by EverLookNeerSee@Github on 4/14/20.
! This program gets seconds from user and converts it
! to hour(s), minute(s) and second(s)

program convert_time
    implicit none
    integer :: hour, minute, second, temp, input_secs
    print *, "Enter seconds: "
    read *, input_secs
    second = mod(input_secs, 60)
    temp = input_secs / 60
    minute = mod(temp, 60)
    hour = temp / 60
    print *, input_secs, "seconds --> ", hour, "hour(s)", &
            minute, "minute(s)", second, "second(s)."
end program convert_time


! { dg-do run }
! PR 22217:  Z edit descriptor with negative numbers used to give lots of *

program main
  character(len=70) line
  character(len=20) fmt
  write(unit=line,fmt='(Z4)') -1_1
  if (line(1:4) .ne. '  FF') call abort
  write(unit=line,fmt='(Z5)') -1_2
  if (line(1:5) .ne. ' FFFF') call abort
  write(unit=line,fmt='(Z9)') -1_4
  if (line(1:9) .ne. ' FFFFFFFF') call abort
  write(unit=line,fmt='(Z17)') -2_8
  if (line(1:17) .ne. ' FFFFFFFFFFFFFFFE') call abort
  write(unit=line,fmt='(Z2)') 10_8
  if (line(1:2) .ne. ' A') call abort

  write(unit=line,fmt='(Z8)') -43_8
  if (line(1:1) .ne. '*') call abort

  write(unit=line,fmt='(B65)') -1_8
  if (line(1:2) .ne. ' 1') call abort
  if (line(64:66) .ne. '11 ') call abort

  write(unit=line,fmt='(O4)') -2_1
  if (line(1:4) .ne. ' 376') call abort
end


module FFWIndices

    implicit none

    contains

    subroutine fuelMoisture(noonHumid, noonWind, initFine, initMoist, eqDry, ffm, r, t)

        integer, intent(in) :: noonHumid, noonWind
        real, intent(in) :: t, initFine
        real, intent(out) :: initMoist, eqDry, ffm
        real, intent(inout) :: r
        real :: ra, rainFunc, corrRain, rainFine, eqWet, dayMoist, z, x

        if (r > 0.5) then
            ra = r
            if (ra <= 1.45) then
                rainFunc = 123.85 - (55.6 * log(ra + 1.016))
            else
                if (ra - 5.75 <= 0.0) then
                    rainFunc = 57.87 - (18.2 * log(ra - 1.016))
                else
                    rainFunc = 40.69 - (8.25 * log(ra - 1.905))
                end if
            end if
            corrRain = 8.73 * exp(-0.1117 * initFine)
            rainFine = (initFine / 100.0) * rainFunc + (1.0 - corrRain)
            if (rainFine < 0.0) then
                rainFine = 0.0
            end if
        else
            r = 0.0
            rainFine = initFine
        end if

        initMoist = 101.0 - rainFine
        eqDry = 0.942 * (noonHumid**0.679)+(11. * exp((noonHumid - 100.0) / 10.0)) + 0.18 * (21.1 - t)&
        & * (1.0 - 1.0 / exp(0.115 * noonHumid))

        if (initMoist-eqDry < 0.0) then
            eqWet = 0.618 * (noonHumid**0.753) + (10.0 * exp((noonHumid - 100.0) / 10.0)) + 0.18 * (21.1 - t)&
            & * (1.0 - 1.0 / exp(0.115 * noonHumid))
            if (initMoist >= eqWet) then
                dayMoist = initMoist
            else
                dayMoist = eqWet - (eqWet - initMoist) / 1.9953
            end if
        else if (initMoist-eqDry == 0.0) then
            dayMoist = initMoist
        else
            z = 0.424 * (1.0 - (noonHumid / 100.0)**1.7) + (0.0694 * (noonWind**0.5)) * (1.0 - (noonHumid / 100.0)**8)
            x = z * (0.463 * (exp(0.0365 * t)))
            dayMoist = eqDry + (initMoist - eqDry) / 10.0**x
        end if

        ffm = 101.0 - dayMoist

        if (ffm > 101.0) then
            ffm = 101.0
        else if(ffm < 0.0) then
            ffm = 0.0
        end if

        return

    end subroutine fuelMoisture

    subroutine duffMoisture(noonHumid, initDuff, dryFactDMC, effRain, funcRainEff, dmc, el, ra, t, j, r)

        real, dimension(12) :: el
        integer, intent(in) :: noonHumid, j
        real, intent(in) :: r, initDuff
        real, intent(out) :: dmc
        real, intent(inout) :: t
        real :: dryFactDMC, ra, effRain, funcRainEff, contMoist, rainMoist, rainDuff

        if (t + 1.1 < 0.0) then
            t = -1.1
        end if

        dryFactDMC = 1.894 * (t + 1.1) * (100.0 - noonHumid) * (el(j) * 0.0001)

        if (r > 1.5) then
            ra = r
            effRain = 0.92 * ra - 1.27
            contMoist = 20.0 + 280. / exp(0.023 * initDuff)
            if (initDuff <= 33.) then
                funcRainEff = 100. / (0.5 + 0.3 * initDuff)
            else if (initDuff - 65.0 <= 0.0) then
                funcRainEff = 14. - 1.3 * log(initDuff)
            else
                funcRainEff = 6.2 * log(initDuff) - 17.2
            end if
            rainMoist = contMoist + (1000.0 * effRain) / (48.77 + funcRainEff * effRain)
            rainDuff = 43.43 * (5.6348 - log(rainMoist - 20.0))
        else
            rainDuff = initDuff
        end if

        if (rainDuff < 0.0) then
            rainDuff = 0.0
        end if

        dmc = rainDuff + dryFactDMC

        return

    end subroutine duffMoisture

    subroutine droughtCode(initDrought, fl, dc, r, j, t)

        real, dimension(12) :: fl
        integer, intent(in) :: j
        real, intent(in) :: r, initDrought
        real, intent(out) :: dc
        real, intent(inout) :: t
        real :: dryFactDC, effRain, moistEq, rainDrought, ra

        if (t + 2.8 < 0.0) then
            t = -2.8
        end if

        dryFactDC = (0.36 * (t + 2.8) + fl(j)) / 2.0

        if (r > 2.8) then
            ra = r
            effRain = 0.83 * ra - 1.27
            moistEq = 800.0 * exp(-initDrought / 400.0)
            rainDrought = initDrought - 400.0 * log(1.0 + ((3.937 * effRain) / moistEq))
            if (rainDrought <= 0.0) then
                rainDrought = 0.0
            end if
            dc = rainDrought + dryFactDC
        else
            rainDrought = initDrought
            dc = rainDrought + dryFactDC
        end if

        if (dc < 0.0) then
            dc = 0.0
        end if

        return

    end subroutine droughtCode

    subroutine index(noonWind, ffm, dmc, dc, indexDC, indexFFM, indexDMC, indexSI, indexBUI, indexFWI)

        integer, intent(in) :: noonWind
        integer, intent(out) :: indexDC, indexFFM, indexDMC, indexSI, indexBUI, indexFWI
        real, intent(inout) :: ffm, dmc, dc
        real :: dayFine, sf, ratio, cc, bb, logFWI, si, bui, fwi

        dayFine = 101.0 - ffm
        sf = 19.1152 * exp(-0.1386 * dayFine) * (1.0 + dayFine**4.65 / 7950000.0)
        si = sf * exp(0.05039 * noonWind)
        bui = (0.8 * dc * dmc) / (dmc + 0.4 * dc)

        if (bui < dmc) then
            ratio = (dmc - bui) / dmc
            cc = 0.92 + (0.0114 * dmc)**1.7
            bui = dmc - (cc * ratio)
            if (bui < 0.0) then
                    bui = 0.0
            end if
        end if

        if (bui > 80.0) then
            bb = 0.1 * si * (1000.0 / (25.0 + 108.64 / exp(0.023 * bui)))
        else
            bb = 0.1 * si * (0.626 * bui**0.809 + 2.0)
        end if

        if (bb - 1.0 <= 0.0) then
            fwi = bb
        else
            logFWI = 2.72 * (0.43 * log(bb))**0.647
            fwi = exp(logFWI)
        end if

        indexDC = int(dc + 0.5)
        indexFFM = int(ffm + 0.5)
        indexDMC = int(dmc + 0.5)
        indexSI = int(si + 0.5)
        indexBUI = int(bui + 0.5)
        indexFWI = int(fwi + 0.5)

        return
    end subroutine index

end module FFWIndices