program gridgenlaval2d
  implicit none

  !*****************************************************************************
  ! Grid generator for SFB708 Laval nozzle based on external triangle mesher
  !
  ! Configuration
  !
  !      w1
  !    +----+
  !    |    |h1
  !    |    | w2
  !    |    +----+                                           w3
  !    |         |h2                                   +------------+
  !    |         |                                     |            |
  !    +         + - - -+ (x1,y1)                      |            |
  !    :         +  ang1                               |            |
  !    * h0       +     | r1            ---------------+            |h3
  !    : r0        +          ----------                            |
  !    +            + - +----- ang2 - - - - - - - - - -+            |
  !    |                                                            |
  !    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
  !    |<------------------- length ------------------>|
  !
  !    h0,r0   : height of the midpoint and radius of the inlet
  !    w1,w2   : widths of the inlet chamber
  !    h1,h2   : heights of the inlet chamber
  !    length  : total length of the nozzle (without outlet chamber)
  !    (x1,y1) : position of the circle midpoints
  !    r1,ang1 : radius and angle of the circle segment
  !    ang2    : angle of the diverging chamber
  !    w3,h3   : width and height of the outlet chamber
  !
  ! The configuration is mirrored along the x-axis and starts at #.
  !
  !*****************************************************************************

  ! Definition of double precision
  integer, parameter  :: DP = selected_real_kind(15,307)

  ! Definition of mathematical constant PI
  real(DP) :: pi

  ! Predefined values
  real(DP) :: dangle1  = 85.0_DP
  real(DP) :: dangle2  =  2.0_DP
  real(DP) :: ddistin  =  1.0_DP
  real(DP) :: ddistout =  1.0_DP
  real(DP) :: ddistcon =  1.0_DP
  real(DP) :: ddistdiv =  1.0_DP
  real(DP) :: dheight0 =  7.0_DP
  real(DP) :: dheight1 =  1.0_DP
  real(DP) :: dheight2 =  1.0_DP
  real(DP) :: dheight3 = 14.0_DP
  real(DP) :: dlength  = 58.85_DP
  real(DP) :: dradius0 =  2.0_DP
  real(DP) :: dradius1 = 11.75_DP
  real(DP) :: dwidth1  =  1.0_DP
  real(DP) :: dwidth2  =  1.0_DP
  real(DP) :: dwidth3  = 14.0_DP
  real(DP) :: dx1      =  0.0_DP
  real(DP) :: dy1      = 13.0_DP

  ! Total number of fixed points
  integer, parameter :: ncoords = 22

  ! Coordinates
  real(DP), dimension(2,ncoords) :: Dpoints

  ! Definition of output filename
  character(len=1024) :: coutputfile = "grid"

  ! Options passed to triangle
  character(len=1024) :: ctriangleopts = "-j -C"

  ! Definition of output format
  character(LEN=*), parameter :: cFormat = '(F32.15)'

  ! Use rz-coordinates
  logical :: brzCoords = .false.

  ! local variables
  character(len=80) :: cbuffer
  character(len=32) :: cbuffer1,cbuffer2,cbuffer3,cbuffer4,cbuffer5,cbuffer6
  logical :: brewrite
  real(DP) :: domega,dsegmentlen,dx,dy,dpar
  integer :: i,i1,i2,i3,i4,ibdc,iel,ipoint,isubpoint,ivt
  integer :: nel,npoints,nsubsegments,nvt,npar

  !-----------------------------------------------------------------------------
  ! Initialize mathematical constant(s)
  !-----------------------------------------------------------------------------

  pi = asin(1.0_DP)*2.0_DP

  !-----------------------------------------------------------------------------
  ! Get command line arguments
  !-----------------------------------------------------------------------------

  call getCmdArgs()

  dangle1 = pi/180.0_DP*dangle1
  dangle2 = pi/180.0_DP*dangle2

  !-----------------------------------------------------------------------------
  ! Write statistics
  !-----------------------------------------------------------------------------

  write(*,'(A)') 'Generating grid'
  write(*,'(A)') '---------------'
  write(*,'(A,T45,A)') 'name of output file: ',trim(adjustl(coutputfile))

  !-----------------------------------------------------------------------------
  ! Generate coordinates of all corners
  !-----------------------------------------------------------------------------

  if (brzCoords) then
    call genCorners_rz
  else
    call genCorners_xy
  end if

  !-----------------------------------------------------------------------------
  ! Generate PRM-file
  !-----------------------------------------------------------------------------

  if (brzCoords) then
    call genPRM_rz
  else
    call genPRM_xy
  end if

  !-----------------------------------------------------------------------------
  ! Generate PSLG (planar straight line graph) for the external program triangle
  !-----------------------------------------------------------------------------

  if (brzCoords) then
    call genPSLR_rz
  else
    call genPSLR_xy
  end if

  ! Call triangle mesh generator with specified options
  write(*,*) "Calling triangle with the following options:"
  write(*,*) trim(adjustl(ctriangleopts))
  call system('triangle '//trim(adjustl(ctriangleopts)))

  !---------------------------------------------------------------------------
  ! Read data for inner triangulation and convert it into TRI format
  !---------------------------------------------------------------------------

  open(unit=100, file=trim(adjustl(coutputfile))//'.1.node')
  read(100, fmt=*) nvt
  close(100)

  open(unit=100, file=trim(adjustl(coutputfile))//'.1.ele')
  read(100, fmt=*) nel
  close(100)

  !-----------------------------------------------------------------------------
  ! Generate TRI-file
  !-----------------------------------------------------------------------------

  call genTRI

contains

  ! Here, the real working routines follwo

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

  subroutine getCmdArgs

    do i = 1, command_argument_count()

      call get_command_argument(i, cbuffer)
      select case(cbuffer)
      case('-h','-H','--help')
        write(*,'(A)') 'Usage: gridgenlaval2d [OPTION]'
        write(*,'(A)') 'Generate grid for laval nozzle in TRI/PRM format.'
        write(*,*)
        write(*,'(A)') "      w1"
        write(*,'(A)') "    +----+"
        write(*,'(A)') "    |    |h1"
        write(*,'(A)') "    |    | w2"
        write(*,'(A)') "    |    +----+                                           w3"
        write(*,'(A)') "    |         |h2                                   +------------+"
        write(*,'(A)') "    |         |                                     |            |"
        write(*,'(A)') "    +         + - - -+ (x1,y1)                      |            |"
        write(*,'(A)') "    :         +  ang1                               |            |"
        write(*,'(A)') "    * h0       +     | r1            ---------------+            |h3"
        write(*,'(A)') "    : r0        +          ----------                            |"
        write(*,'(A)') "    +            + - +----- ang2 - - - - - - - - - -+            |"
        write(*,'(A)') "    |                                                            |"
        write(*,'(A)') "    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +"
        write(*,'(A)') "    |<------------------- length ------------------>|"
        write(*,*)
        write(*,'(A,T30,A)') '-a,  --area','average area of triangles'
        write(*,'(A,T30,A)') '-a1, --angle1','angle of the circle segment'
        write(*,'(A,T30,A)') '-a2, --angle2','angle of the diverging chamber'
        write(*,'(A,T30,A)') '-D,  --Delaunay','generate conforming Delaunay '//&
            'triangulation and not just constrained Delaunay triangulation'
        write(*,'(A,T30,A)') '-di,  --distinlet','average distance between '//&
            'points along the inlet boundary'
        write(*,'(A,T30,A)') '-dc,  --distconvergent','average distance between '//&
            'points along the convergent part of the boundary'
        write(*,'(A,T30,A)') '-dd,  --distdivergent','average distance between '//&
            'points along the divergent part of the boundary'
        write(*,'(A,T30,A)') '-do,  --distoutlet','average distance between '//&
            'points along the outlet boundary'
        write(*,'(A,T30,A)') '-F, --Fortune','use Steven Fortunes algorithm for '//&
            'Delaunay triangulation'
        write(*,'(A,T30,A)') '-h,  -H,  --help','this help screen'
        write(*,'(A,T30,A)') '-h0, --height0','height of the midpoint of the inlet'
        write(*,'(A,T30,A)') '-h1, --height1','height of the inlet chamber'
        write(*,'(A,T30,A)') '-h2, --height2','height of the inlet chamber'
        write(*,'(A,T30,A)') '-h3, --height3','height of the outlet chamber'
        write(*,'(A,T30,A)') '-i, --incremental','use incremental algorithm for Delaunay triangulation'
        write(*,'(A,T30,A)') '-l,  --length','length of the nozzle (without outlet chamber)'
        write(*,'(A,T30,A)') '-o,  --outputfile','name of the output file'
        write(*,'(T30,A)')   'If not given, the generated grid is stored in file "grid.tri/prm".'
        write(*,'(A,T30,A)') '-Q, --quiet','suppress output other than errors'
        write(*,'(A,T30,A)') '-q,  --quality','Quality mesh generation with no '//&
            'angles smaller than 20 degrees'
        write(*,'(A,T30,A)') '-r0, --radius0','radius of the inlet'
        write(*,'(A,T30,A)') '-r1, --radius1','radius of the circle segment'
        write(*,'(A,T30,A)') '-rz', 'use rz-coodinate system'
        write(*,'(A,T30,A)') '-x1','horizontal position of the circle segment'
        write(*,'(A,T30,A)') '-xy', 'use xy-coodinate system (default)'
        write(*,'(A,T30,A)') '-V, --verbose','print detailed information'
        write(*,'(A,T30,A)') '-Y','do not insert Steiner points on the boundary'
        write(*,'(A,T30,A)') '-YY','do not insert Steiner points anywhere'
        write(*,'(A,T30,A)') '-y1','vertical position of the circle segment'
        write(*,'(A,T30,A)') '-w1, --width1','width of the inlet chamber'
        write(*,'(A,T30,A)') '-w2, --width2','width of the inlet chamber'
        write(*,'(A,T30,A)') '-w3, --width3','width of the outlet chamber'
        write(*,*)
        write(*,'(A)') 'Report bugs to <matthias.moeller@math.tu-dortmund.de>.'
        stop

      case('-A','--Area')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -a'

      case('-a','--area')
        call get_command_argument(i+1, cbuffer)
        ctriangleopts = trim(adjustl(ctriangleopts))//' -a'//trim(adjustl(cbuffer))

      case('-a1','--angle1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dangle1

      case('-a2','--angle2')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dangle2

      case('-D','--Delaunay')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -D'

      case('-di','--distinlet')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) ddistin

      case('-do','--distoutlet')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) ddistout

      case('-dc','--distconvergent')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) ddistcon

      case('-dd','--distdivergent')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) ddistdiv

      case('-F','--Fortune')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -F'

      case('-h0','--height0')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dheight0

      case('-h1','--height1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dheight1

      case('-h2','--height2')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dheight2

      case('-h3','--height3')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dheight3

      case('-i','--incremental')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -i'

      case('-l','--length')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dlength

      case('-o','--outputfile')
        call get_command_argument(i+1, coutputfile)
        ctriangleopts = trim(adjustl(ctriangleopts))//' -p '//trim(adjustl(coutputfile))

      case('-Q','--quiet')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -Q'

      case('-q','--quality')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -q'

      case('-r0','--radius0')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dradius0

      case('-r1','--radius1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dradius1

      case('-rz')
        brzCoords = .true.

      case('-x1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dx1

      case('-xy')
        brzCoords = .false.

      case('-V','--verbose')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -V'

      case('-Y')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -Y'

      case('-YY')
        ctriangleopts = trim(adjustl(ctriangleopts))//' -YY'

      case('-y1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dy1

      case('-w1','--width1')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dwidth1

      case('-w2','--width2')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dwidth2

      case('-w3','--width3')
        call get_command_argument(i+1, cbuffer)
        read(cbuffer,*) dwidth3

      end select
    end do
  end subroutine getCmdArgs

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

  subroutine genCorners_xy

    Dpoints(1,1) =  dx1-dradius1-dwidth1-dwidth2
    Dpoints(2,1) = -(dy1+dheight1+dheight2)

    Dpoints(1,2) =  dx1-dradius1-dwidth2
    Dpoints(2,2) =  Dpoints(2,1)

    Dpoints(1,3) =  Dpoints(1,2)
    Dpoints(2,3) = -(dy1+dheight2)

    Dpoints(1,4) =  dx1-dradius1
    Dpoints(2,4) =  Dpoints(2,3)

    Dpoints(1,5) =  Dpoints(1,4)
    Dpoints(2,5) = -dy1

    Dpoints(1,6) =  dx1+dradius1*cos(pi-dangle1)
    Dpoints(2,6) = -dy1+dradius1*sin(pi-dangle1)

    Dpoints(1,7) =  dx1+(dlength-dradius1-dwidth1-dwidth2)
    Dpoints(2,7) =  Dpoints(2,6)-tan(dangle2)*(Dpoints(1,7)-Dpoints(1,6))

    Dpoints(1,8) =  Dpoints(1,7)
    Dpoints(2,8) = -dheight3

    Dpoints(1,9) = Dpoints(1,8)+dwidth3
    Dpoints(2,9) = Dpoints(2,8)

    Dpoints(1,10:18) =  Dpoints(1,9:1:-1)
    Dpoints(2,10:18) = -Dpoints(2,9:1:-1)

    Dpoints(1,19) = Dpoints(1,18)
    Dpoints(2,19) = min(Dpoints(2,18),&
        0.5_DP*(Dpoints(2,18)+Dpoints(2,1))+dheight0+dradius0)

    Dpoints(1,20) = Dpoints(1,18)
    Dpoints(2,20) = min(Dpoints(2,18),&
        0.5_DP*(Dpoints(2,18)+Dpoints(2,1))+dheight0-dradius0)

    if (dradius0 >= dheight0) then
      Dpoints(:,21) = Dpoints(:,20)
      Dpoints(:,22) = Dpoints(:,20)
    else
      Dpoints(1,21) = Dpoints(1,18)
      Dpoints(2,21) = max(Dpoints(2,1),&
          0.5_DP*(Dpoints(2,18)+Dpoints(2,1))-dheight0+dradius0)

      Dpoints(1,22) = Dpoints(1,18)
      Dpoints(2,22) = max(Dpoints(2,1),&
          0.5_DP*(Dpoints(2,18)+Dpoints(2,1))-dheight0-dradius0)
    end if

  end subroutine genCorners_xy

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

  subroutine genCorners_rz

    Dpoints(1,1) =  dx1-dradius1-dwidth1-dwidth2
    Dpoints(2,1) = -(dy1+dheight1+dheight2)

    Dpoints(1,2) =  dx1-dradius1-dwidth2
    Dpoints(2,2) =  Dpoints(2,1)

    Dpoints(1,3) =  Dpoints(1,2)
    Dpoints(2,3) = -(dy1+dheight2)

    Dpoints(1,4) =  dx1-dradius1
    Dpoints(2,4) =  Dpoints(2,3)

    Dpoints(1,5) =  Dpoints(1,4)
    Dpoints(2,5) = -dy1

    Dpoints(1,6) =  dx1+dradius1*cos(pi-dangle1)
    Dpoints(2,6) = -dy1+dradius1*sin(pi-dangle1)

    Dpoints(1,7) =  dx1+(dlength-dradius1-dwidth1-dwidth2)
    Dpoints(2,7) =  Dpoints(2,6)-tan(dangle2)*(Dpoints(1,7)-Dpoints(1,6))

    Dpoints(1,8) =  Dpoints(1,7)
    Dpoints(2,8) = -dheight3

    Dpoints(1,9) = Dpoints(1,8)+dwidth3
    Dpoints(2,9) = Dpoints(2,8)

    Dpoints(1,10:18) = Dpoints(1,9:1:-1)
    Dpoints(2,10:18) = 0.0_DP

    Dpoints(1,19) = Dpoints(1,18)
    Dpoints(2,19) = min(Dpoints(2,18),&
        0.5_DP*(Dpoints(2,18)+Dpoints(2,1))+dheight0+dradius0)

    Dpoints(1,20) = Dpoints(1,18)
    Dpoints(2,20) = min(Dpoints(2,18),&
        0.5_DP*(Dpoints(2,18)+Dpoints(2,1))+dheight0-dradius0)

    if (dradius0 >= dheight0) then
      Dpoints(:,21) = Dpoints(:,20)
      Dpoints(:,22) = Dpoints(:,20)
    else
      Dpoints(1,21) = Dpoints(1,18)
      Dpoints(2,21) = max(Dpoints(2,1),&
          0.5_DP*(Dpoints(2,18)+Dpoints(2,1))-dheight0+dradius0)

      Dpoints(1,22) = Dpoints(1,18)
      Dpoints(2,22) = max(Dpoints(2,1),&
          0.5_DP*(Dpoints(2,18)+Dpoints(2,1))-dheight0-dradius0)
    end if

    ! Post correction
    Dpoints(1:2,19) = Dpoints(1:2,21)
    Dpoints(1:2,20) = Dpoints(1:2,22)

  end subroutine genCorners_rz

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

  subroutine genPRM_xy

    open(unit=100, file=trim(adjustl(coutputfile))//'.prm')

    write(100,'(A)') 'NBCT'
    write(100,'(A)') '1'
    write(100,'(A)') 'IBCT'
    write(100,'(A)') '1 '
    write(100,'(A)') 'NCOMP'

    write(cbuffer1, fmt='(I4)') 4 + merge(2,0,dheight1 /= 0.0_DP)&
        + merge(2,0,dheight2 /= 0.0_DP)&
        + merge(2,0,dwidth1  /= 0.0_DP)&
        + merge(2,0,dwidth2  /= 0.0_DP)&
        + merge(5,1,dwidth3  >  0.0_DP)&
        + merge(5,merge(1,3,dradius0 >= dheight0),&
        dheight0 > 0.0_DP .and. dradius0 < dheight0)

    write(100,'(A)') trim(adjustl(cbuffer1))
    write(100,'(A)') 'ITYP NSPLINE NPAR'
    if (dwidth1  /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dheight1 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dwidth2  /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dheight2 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    write(100,'(A)') '2 1 3 '   ! lower circle segment

    write(100,'(A)') '1 1 2 '   ! lower converging chamber
    if (dwidth3  > 0.0_DP) then
      ! Note that we do not check the special case that
      ! dwidth3 equals the height of the exit throat
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 ' ! lower boundary outlet chamber
      write(100,'(A)') '1 1 2 ' ! right boundary outlet chamber
      write(100,'(A)') '1 1 2 ' ! upper boundary outlet chamber
      write(100,'(A)') '1 1 2 '
    else
      write(100,'(A)') '1 1 2 ' ! outlet boundary without chamber
    end if
    write(100,'(A)') '1 1 2 '   ! upper converging chamber
    write(100,'(A)') '2 1 3 '   ! upper circle segment
    if (dheight2 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dwidth2  /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dheight1 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dwidth1  /= 0.0_DP) write(100,'(A)') '1 1 2 '

    ! left boundary inlet chamber
    if (dheight0 > 0.0_DP .and. dradius0 < dheight0) then
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
    else if (dradius0 >= dheight0) then
      write(100,'(A)') '1 1 2 '
    else
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
    end if

    write(100,'(A)') 'PARAMETERS'
    ! Line segment
    if (dwidth1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,1)
      write(cbuffer2, cFormat) Dpoints(2,1)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,2)-Dpoints(1,1)
      write(cbuffer2, cFormat) Dpoints(2,2)-Dpoints(2,1)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dheight1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,2)
      write(cbuffer2, cFormat) Dpoints(2,2)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,3)-Dpoints(1,2)
      write(cbuffer2, cFormat) Dpoints(2,3)-Dpoints(2,2)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dwidth2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,3)
      write(cbuffer2, cFormat) Dpoints(2,3)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,4)-Dpoints(1,3)
      write(cbuffer2, cFormat) Dpoints(2,4)-Dpoints(2,3)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dheight2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,4)
      write(cbuffer2, cFormat) Dpoints(2,4)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,5)-Dpoints(1,4)
      write(cbuffer2, cFormat) Dpoints(2,5)-Dpoints(2,4)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Circular segment
    write(cbuffer1, cFormat)  dx1
    write(cbuffer2, cFormat) -dy1
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! midpoint
    write(cbuffer1, cFormat) dradius1
    write(cbuffer2, cFormat) 0.0_DP
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! radius1
    write(cbuffer1, cFormat) pi
    write(cbuffer2, cFormat) pi-dangle1
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! angle1

    ! Line segment
    write(cbuffer1, cFormat) Dpoints(1,6)
    write(cbuffer2, cFormat) Dpoints(2,6)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,7)-Dpoints(1,6)
    write(cbuffer2, cFormat) Dpoints(2,7)-Dpoints(2,6)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction

    ! Outlet chamber?
    if (dwidth3 > 0.0_DP) then
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,8)-Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,8)-Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,8)
      write(cbuffer2, cFormat) Dpoints(2,8)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,9)-Dpoints(1,8)
      write(cbuffer2, cFormat) Dpoints(2,9)-Dpoints(2,8)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,9)
      write(cbuffer2, cFormat) Dpoints(2,9)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,10)-Dpoints(1,9)
      write(cbuffer2, cFormat) Dpoints(2,10)-Dpoints(2,9)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,10)
      write(cbuffer2, cFormat) Dpoints(2,10)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,11)-Dpoints(1,10)
      write(cbuffer2, cFormat) Dpoints(2,11)-Dpoints(2,10)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,11)
      write(cbuffer2, cFormat) Dpoints(2,11)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,12)-Dpoints(1,11)
      write(cbuffer2, cFormat) Dpoints(2,12)-Dpoints(2,11)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    else
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,12)-Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,12)-Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segments
    write(cbuffer1, cFormat) Dpoints(1,12)
    write(cbuffer2, cFormat) Dpoints(2,12)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,13)-Dpoints(1,12)
    write(cbuffer2, cFormat) Dpoints(2,13)-Dpoints(2,12)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    ! Circular segment
    write(cbuffer1, cFormat) dx1
    write(cbuffer2, cFormat) dy1
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! midpoint
    write(cbuffer1, cFormat) dradius1
    write(cbuffer2, cFormat) 0.0_DP
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! radius1
    write(cbuffer1, cFormat) pi+dangle1
    write(cbuffer2, cFormat) pi
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! angle1
    ! Line segment
    if (dheight2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,14)
      write(cbuffer2, cFormat) Dpoints(2,14)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,15)-Dpoints(1,14)
      write(cbuffer2, cFormat) Dpoints(2,15)-Dpoints(2,14)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dwidth2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,15)
      write(cbuffer2, cFormat) Dpoints(2,15)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,16)-Dpoints(1,15)
      write(cbuffer2, cFormat) Dpoints(2,16)-Dpoints(2,15)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dheight1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,16)
      write(cbuffer2, cFormat) Dpoints(2,16)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,17)-Dpoints(1,16)
      write(cbuffer2, cFormat) Dpoints(2,17)-Dpoints(2,16)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dwidth1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,17)
      write(cbuffer2, cFormat) Dpoints(2,17)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,18)-Dpoints(1,17)
      write(cbuffer2, cFormat) Dpoints(2,18)-Dpoints(2,17)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if

    ! left boundary inlet chamber
    if (dheight0 > 0.0_DP .and. dradius0 < dheight0) then
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,19)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,19)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,19)
      write(cbuffer2, cFormat) Dpoints(2,19)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,20)-Dpoints(1,19)
      write(cbuffer2, cFormat) Dpoints(2,20)-Dpoints(2,19)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,20)
      write(cbuffer2, cFormat) Dpoints(2,20)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,21)-Dpoints(1,20)
      write(cbuffer2, cFormat) Dpoints(2,21)-Dpoints(2,20)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,21)
      write(cbuffer2, cFormat) Dpoints(2,21)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,22)-Dpoints(1,21)
      write(cbuffer2, cFormat) Dpoints(2,22)-Dpoints(2,21)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    elseif (dradius0 >= dheight0) then
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    else
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,19)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,19)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,19)
      write(cbuffer2, cFormat) Dpoints(2,19)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,20)-Dpoints(1,19)
      write(cbuffer2, cFormat) Dpoints(2,20)-Dpoints(2,19)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,20)
      write(cbuffer2, cFormat) Dpoints(2,20)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,20)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,20)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if

    close(100)

  end subroutine genPRM_xy

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

  subroutine genPRM_rz

    open(unit=100, file=trim(adjustl(coutputfile))//'.prm')

    write(100,'(A)') 'NBCT'
    write(100,'(A)') '1'
    write(100,'(A)') 'IBCT'
    write(100,'(A)') '1 '
    write(100,'(A)') 'NCOMP'

    write(cbuffer1, fmt='(I4)') 4 + merge(1,0,dheight1 /= 0.0_DP)&
                                  + merge(1,0,dheight2 /= 0.0_DP)&
                                  + merge(1,0,dwidth1  /= 0.0_DP)&
                                  + merge(1,0,dwidth2  /= 0.0_DP)&
                                  + merge(4,1,dwidth3  >  0.0_DP)&
                                  + merge(3,merge(1,2,dradius0 >= dheight0),&
                                  dheight0 > 0.0_DP .and. dradius0 < dheight0)

    write(100,'(A)') trim(adjustl(cbuffer1))
    write(100,'(A)') 'ITYP NSPLINE NPAR'
    if (dwidth1  /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dheight1 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dwidth2  /= 0.0_DP) write(100,'(A)') '1 1 2 '
    if (dheight2 /= 0.0_DP) write(100,'(A)') '1 1 2 '
    write(100,'(A)') '2 1 3 '   ! lower circle segment

    write(100,'(A)') '1 1 2 '   ! lower converging chamber
    if (dwidth3  > 0.0_DP) then
      ! Note that we do not check the special case that
      ! dwidth3 equals the height of the exit throat
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 ' ! lower boundary outlet chamber
      write(100,'(A)') '1 1 2 ' ! right boundary outlet chamber
      write(100,'(A)') '1 1 2 ' ! upper boundary outlet chamber
    else
      write(100,'(A)') '1 1 2 ' ! outlet boundary without chamber
    end if
    write(100,'(A)') '1 1 2 '   ! upper segment (converging chamber)
    write(100,'(A)') '1 1 2 '   ! upper segment (circle segment
    write(100,'(A)') '1 1 2 '   ! upper segment (inlet chamber)

    ! left boundary inlet chamber
    if (dheight0 > 0.0_DP .and. dradius0 < dheight0) then
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
    else if (dradius0 >= dheight0) then
      write(100,'(A)') '1 1 2 '
    else
      write(100,'(A)') '1 1 2 '
      write(100,'(A)') '1 1 2 '
    end if

    write(100,'(A)') 'PARAMETERS'
    ! Line segment
    if (dwidth1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,1)
      write(cbuffer2, cFormat) Dpoints(2,1)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,2)-Dpoints(1,1)
      write(cbuffer2, cFormat) Dpoints(2,2)-Dpoints(2,1)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dheight1 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,2)
      write(cbuffer2, cFormat) Dpoints(2,2)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,3)-Dpoints(1,2)
      write(cbuffer2, cFormat) Dpoints(2,3)-Dpoints(2,2)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dwidth2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,3)
      write(cbuffer2, cFormat) Dpoints(2,3)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,4)-Dpoints(1,3)
      write(cbuffer2, cFormat) Dpoints(2,4)-Dpoints(2,3)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Line segment
    if (dheight2 /= 0.0_DP) then
      write(cbuffer1, cFormat) Dpoints(1,4)
      write(cbuffer2, cFormat) Dpoints(2,4)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,5)-Dpoints(1,4)
      write(cbuffer2, cFormat) Dpoints(2,5)-Dpoints(2,4)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if
    ! Circular segment
    write(cbuffer1, cFormat)  dx1
    write(cbuffer2, cFormat) -dy1
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! midpoint
    write(cbuffer1, cFormat) dradius1
    write(cbuffer2, cFormat) 0.0_DP
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! radius1
    write(cbuffer1, cFormat) pi
    write(cbuffer2, cFormat) pi-dangle1
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! angle1

    ! Line segment
    write(cbuffer1, cFormat) Dpoints(1,6)
    write(cbuffer2, cFormat) Dpoints(2,6)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,7)-Dpoints(1,6)
    write(cbuffer2, cFormat) Dpoints(2,7)-Dpoints(2,6)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction

    ! Outlet chamber?
    if (dwidth3 > 0.0_DP) then
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,8)-Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,8)-Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,8)
      write(cbuffer2, cFormat) Dpoints(2,8)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,9)-Dpoints(1,8)
      write(cbuffer2, cFormat) Dpoints(2,9)-Dpoints(2,8)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,9)
      write(cbuffer2, cFormat) Dpoints(2,9)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,10)-Dpoints(1,9)
      write(cbuffer2, cFormat) Dpoints(2,10)-Dpoints(2,9)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,10)
      write(cbuffer2, cFormat) Dpoints(2,10)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,12)-Dpoints(1,10)
      write(cbuffer2, cFormat) Dpoints(2,12)-Dpoints(2,10)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    else
      ! Line segments
      write(cbuffer1, cFormat) Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,12)-Dpoints(1,7)
      write(cbuffer2, cFormat) Dpoints(2,12)-Dpoints(2,7)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if

    ! Line segments
    write(cbuffer1, cFormat) Dpoints(1,12)
    write(cbuffer2, cFormat) Dpoints(2,12)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,13)-Dpoints(1,12)
    write(cbuffer2, cFormat) Dpoints(2,13)-Dpoints(2,12)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    ! Line segments
    write(cbuffer1, cFormat) Dpoints(1,13)
    write(cbuffer2, cFormat) Dpoints(2,13)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,14)-Dpoints(1,13)
    write(cbuffer2, cFormat) Dpoints(2,14)-Dpoints(2,13)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    ! Line segments
    write(cbuffer1, cFormat) Dpoints(1,14)
    write(cbuffer2, cFormat) Dpoints(2,14)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
    write(cbuffer1, cFormat) Dpoints(1,18)-Dpoints(1,14)
    write(cbuffer2, cFormat) Dpoints(2,18)-Dpoints(2,14)
    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction

    ! left boundary inlet chamber
    if (dheight0 > 0.0_DP .and. dradius0 < dheight0) then
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) 0.0_DP
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,21)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,21)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,21)
      write(cbuffer2, cFormat) Dpoints(2,21)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,22)-Dpoints(1,21)
      write(cbuffer2, cFormat) Dpoints(2,22)-Dpoints(2,21)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    elseif (dradius0 >= dheight0) then
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    else
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,22)-Dpoints(1,18)
      write(cbuffer2, cFormat) Dpoints(2,22)-Dpoints(2,18)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
      ! Line segment
      write(cbuffer1, cFormat) Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! coordinate
      write(cbuffer1, cFormat) Dpoints(1,1)-Dpoints(1,22)
      write(cbuffer2, cFormat) Dpoints(2,1)-Dpoints(2,22)
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2)) ! direction
    end if

    close(100)

  end subroutine genPRM_rz

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

  subroutine genPSLR_xy

    ! Initialize the number of points
    npoints = 0
    brewrite = .false.

1   open(unit=100, file=trim(adjustl(coutputfile))//'.poly', form='formatted')

    ! Write file header
    write(100, '(A)') "# "//trim(adjustl(coutputfile))//'.poly'
    write(100, '(A)') "#"
    write(100, '(A)') "# Poly file generated by gridgenlaval2d."
    write(100, '(A)') "#"

    !-----------------------------------------------------------------------------

    ! Write number of points
    write(100, '(A)') "# Number of points, 2D, one attribute, boundary markers"
    write(cbuffer1, '(I10)') npoints
    write(100, '(A)') trim(adjustl(cbuffer1))//' 2 1 1'

    ! Initialize the number of points
    npoints = 0; npar = 0

    ! Write vertex coordinates
    do ipoint = 1, ncoords

      ! Check if points coincide
      if (sqrt((Dpoints(1,ipoint)-Dpoints(1,mod(ipoint,ncoords)+1))**2 +&
          (Dpoints(2,ipoint)-Dpoints(2,mod(ipoint,ncoords)+1))**2) <= 1e-12) cycle

      ! Increase number of points by one
      npoints = npoints+1

      ! Increase number of boundary parameter
      npar = npar+1

      ! Fill buffers
      write(cbuffer1, '(I10)') npoints
      write(cbuffer2, cFormat) Dpoints(1,ipoint)
      write(cbuffer3, cFormat) Dpoints(2,ipoint)
      write(cbuffer4, cFormat) real(npar-1,DP)

      ! Write line to file
      write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                        trim(adjustl(cbuffer2))//' '//&
                        trim(adjustl(cbuffer3))//' '//&
                        trim(adjustl(cbuffer4))//' 1'

      ! Write extra points between two regular points with user-defined
      ! average distance; note that we must distinguish between points
      ! on a straight line and those on a circular segment
      select case(ipoint)
      case(1:4,6:12,14:ncoords)
        ! Compute line segment length
        dsegmentlen = sqrt((Dpoints(1,mod(ipoint,ncoords)+1)-Dpoints(1,ipoint))**2+&
            (Dpoints(2,mod(ipoint,ncoords)+1)-Dpoints(2,ipoint))**2)

        ! Compute number of auxiliary segments
        select case(ipoint)
        case(1:4,14:ncoords)
          nsubsegments = nint(dsegmentlen/ddistin)
        case (6,12)
          nsubsegments = nint(dsegmentlen/ddistdiv)
        case default
          nsubsegments = nint(dsegmentlen/ddistout)
        end select

        ! Write vertex coordinates of auxiliary points
        do isubpoint = 1, nsubsegments-1
          ! Increase number of points by one
          npoints = npoints+1

          ! Compute relative position of the auxiliary point on
          ! the line segment between the points [ipoint,ipoint+1]
          domega = real(isubpoint,DP)/real(nsubsegments,DP)

          ! Fill buffer
          write(cbuffer1, '(I10)') npoints
          write(cbuffer2, cFormat) Dpoints(1,ipoint) +&
              domega*(Dpoints(1,mod(ipoint,ncoords)+1)-Dpoints(1,ipoint))
          write(cbuffer3, cFormat) Dpoints(2,ipoint) +&
              domega*(Dpoints(2,mod(ipoint,ncoords)+1)-Dpoints(2,ipoint))
          write(cbuffer4, cFormat) real(npar-1,DP)+domega

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 1'
        end do

      case(5)
        ! Compute circular segment length
        dsegmentlen = dradius1*dangle1

        ! Compute number of auxiliary segments
        nsubsegments = nint(dsegmentlen/ddistcon)

        ! Write vertex coordinates of auxiliary points
        do isubpoint = 1, nsubsegments-1
          ! Increase number of points by one
          npoints = npoints+1

          ! Compute relative position of the auxiliary point on
          ! the circular segment between the points ipoint and ipoint+1
          domega = real(isubpoint,DP)/real(nsubsegments,DP)

          ! Fill buffer
          write(cbuffer1, '(I10)')  npoints
          write(cbuffer2, cFormat)  dx1+dradius1*cos(pi-dangle1*domega)
          write(cbuffer3, cFormat) -dy1+dradius1*sin(pi-dangle1*domega)
          write(cbuffer4, cFormat)  real(npar-1,DP)+domega

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 1'
        end do

      case(13)
        ! Compute circular segment length
        dsegmentlen = dradius1*dangle1

        ! Compute number of auxiliary segments
        nsubsegments = nint(dsegmentlen/ddistcon)

        ! Write vertex coordinates of auxiliary points
        do isubpoint = nsubsegments-1, 1, -1
          ! Increase number of points by one
          npoints = npoints+1

          ! Compute relative position of the auxiliary point on
          ! the circular segment between the points ipoint and ipoint+1
          domega = real(isubpoint,DP)/real(nsubsegments,DP)

          ! Fill buffer
          write(cbuffer1, '(I10)')  npoints
          write(cbuffer2, cFormat)  dx1+dradius1*cos(pi-dangle1*domega)
          write(cbuffer3, cFormat)  dy1-dradius1*sin(pi-dangle1*domega)
          write(cbuffer4, cFormat)  real(npar-1,DP)+(1.0_DP-domega)

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 1'
        end do
      end select
    end do

    ! Write number of segments
    write(100, '(A)') "# Number of segments, boundary markers"
    write(cbuffer1, '(I10)') npoints
    write(100, '(A)') trim(adjustl(cbuffer1))//' 1'

    ! Write segments
    do ipoint = 1, npoints

      ! Fill buffers
      write(cbuffer1, '(I10)') ipoint
      write(cbuffer2, '(I10)') ipoint
      write(cbuffer3, '(I10)') mod(ipoint,npoints)+1

      write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                        trim(adjustl(cbuffer2))//' '//&
                        trim(adjustl(cbuffer3))//' 1'
    end do

    ! Write number of holes
    write(100, '(A)') "# Number of holes"
    write(100, '(A)') "0"

    ! Write number of regional attributes and/or area constraints
    write(100, '(A)') "# Number of regional attributes and/or area constraints"
    write(100, '(A)') "0"

    close(100)

    ! Now, the number of total points is known and needs to be updated
    if ((npoints /= ncoords) .and. .not.brewrite) then
      brewrite = .true.
      goto 1
    end if

  end subroutine genPSLR_xy

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

  subroutine genPSLR_rz

    ! Initialize the number of points
    npoints = 0
    brewrite = .false.

1   open(unit=100, file=trim(adjustl(coutputfile))//'.poly', form='formatted')

    ! Write file header
    write(100, '(A)') "# "//trim(adjustl(coutputfile))//'.poly'
    write(100, '(A)') "#"
    write(100, '(A)') "# Poly file generated by gridgenlaval2d."
    write(100, '(A)') "#"

    !-----------------------------------------------------------------------------

    ! Write number of points
    write(100, '(A)') "# Number of points, 2D, one attribute, boundary markers"
    write(cbuffer1, '(I10)') npoints
    write(100, '(A)') trim(adjustl(cbuffer1))//' 2 1 1'

    ! Initialize the number of points
    npoints = 0; npar = 0

    ! Write vertex coordinates
    do ipoint = 1, ncoords

      ! Check if points coincide
      if (sqrt((Dpoints(1,ipoint)-Dpoints(1,mod(ipoint,ncoords)+1))**2 +&
          (Dpoints(2,ipoint)-Dpoints(2,mod(ipoint,ncoords)+1))**2) <= 1e-12) cycle

      ! Increase number of points by one
      npoints = npoints+1

      ! Increase number of boundary parameter
      npar = npar+1

      ! Fill buffers
      write(cbuffer1, '(I10)') npoints
      write(cbuffer2, cFormat) Dpoints(1,ipoint)
      write(cbuffer3, cFormat) Dpoints(2,ipoint)
      write(cbuffer4, cFormat) real(npar-1,DP)

      ! Write line to file
      write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                        trim(adjustl(cbuffer2))//' '//&
                        trim(adjustl(cbuffer3))//' '//&
                        trim(adjustl(cbuffer4))//' 1'

      ! Write extra points between two regular points with user-defined
      ! average distance; note that we must distinguish between points
      ! on a straight line and those on a circular segment
      select case(ipoint)
      case(1:4,6:10)
        ! Compute line segment length
        dsegmentlen = sqrt((Dpoints(1,mod(ipoint,ncoords)+1)-Dpoints(1,ipoint))**2+&
            (Dpoints(2,mod(ipoint,ncoords)+1)-Dpoints(2,ipoint))**2)

        ! Compute number of auxiliary segments
        select case(ipoint)
        case(1:4)
          nsubsegments = nint(dsegmentlen/ddistin)
        case (6)
          nsubsegments = nint(dsegmentlen/ddistdiv)
        case default
          nsubsegments = nint(dsegmentlen/ddistout)
        end select

        ! Write vertex coordinates of auxiliary points
        do isubpoint = 1, nsubsegments-1
          ! Increase number of points by one
          npoints = npoints+1

          ! Compute relative position of the auxiliary point on
          ! the line segment between the points [ipoint,ipoint+1]
          domega = real(isubpoint,DP)/real(nsubsegments,DP)

          ! Fill buffer
          write(cbuffer1, '(I10)') npoints
          write(cbuffer2, cFormat) Dpoints(1,ipoint) +&
              domega*(Dpoints(1,mod(ipoint,ncoords)+1)-Dpoints(1,ipoint))
          write(cbuffer3, cFormat) Dpoints(2,ipoint) +&
              domega*(Dpoints(2,mod(ipoint,ncoords)+1)-Dpoints(2,ipoint))
          write(cbuffer4, cFormat) real(npar-1,DP)+domega

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 1'
        end do

      case(5)
        ! Compute circular segment length
        dsegmentlen = dradius1*dangle1

        ! Compute number of auxiliary segments
        nsubsegments = nint(dsegmentlen/ddistcon)

        ! Write vertex coordinates of auxiliary points
        do isubpoint = 1, nsubsegments-1
          ! Increase number of points by one
          npoints = npoints+1

          ! Compute relative position of the auxiliary point on
          ! the circular segment between the points ipoint and ipoint+1
          domega = real(isubpoint,DP)/real(nsubsegments,DP)

          ! Fill buffer
          write(cbuffer1, '(I10)')  npoints
          write(cbuffer2, cFormat)  dx1+dradius1*cos(pi-dangle1*domega)
          write(cbuffer3, cFormat) -dy1+dradius1*sin(pi-dangle1*domega)
          write(cbuffer4, cFormat)  real(npar-1,DP)+domega

          ! Write line to file
          write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                            trim(adjustl(cbuffer2))//' '//&
                            trim(adjustl(cbuffer3))//' '//&
                            trim(adjustl(cbuffer4))//' 1'
        end do
      end select
    end do

    ! Write number of segments
    write(100, '(A)') "# Number of segments, boundary markers"
    write(cbuffer1, '(I10)') npoints
    write(100, '(A)') trim(adjustl(cbuffer1))//' 1'

    ! Write segments
    do ipoint = 1, npoints

      ! Fill buffers
      write(cbuffer1, '(I10)') ipoint
      write(cbuffer2, '(I10)') ipoint
      write(cbuffer3, '(I10)') mod(ipoint,npoints)+1

      write(100, '(A)') trim(adjustl(cbuffer1))//' '//&
                        trim(adjustl(cbuffer2))//' '//&
                        trim(adjustl(cbuffer3))//' 1'
    end do

    ! Write number of holes
    write(100, '(A)') "# Number of holes"
    write(100, '(A)') "0"

    ! Write number of regional attributes and/or area constraints
    write(100, '(A)') "# Number of regional attributes and/or area constraints"
    write(100, '(A)') "0"

    close(100)

    ! Now, the number of total points is known and needs to be updated
    if ((npoints /= ncoords) .and. .not.brewrite) then
      brewrite = .true.
      goto 1
    end if

  end subroutine genPSLR_rz

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

  subroutine genTRI

    open(unit=100, file=trim(adjustl(coutputfile))//'.tri')

    write(100,'(A)') 'Coarse mesh 2D'
    write(100,'(A)') 'Generated by gridgencirc2d'

    write(cbuffer1, '(I10)') nel
    write(cbuffer2, '(I10)') nvt

    write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
        trim(adjustl(cbuffer2))//' 0 3 1  NEL NVT NMT NVE NBCT'

    !---------------------------------------------------------------------------
    write(100,'(A)') 'DCORVG'
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Copy/convert coordinates from external triangulation
    !---------------------------------------------------------------------------

    open(unit=200, file=trim(adjustl(coutputfile))//'.1.node')
    read(200, fmt=*) nvt

    ! Read node file line by line and convert coordinates
    do ivt = 1, nvt
      read(200, fmt=*) i, dx, dy, dpar, ibdc

      if (ibdc == 0) then
        ! Write inner vertex
        write(cbuffer1, cFormat) dx
        write(cbuffer2, cFormat) dy
      else
        ! Write boundary parametrization
        write(cbuffer1, cFormat) dpar
        write(cbuffer2, cFormat) 0.0_DP
      end if

      ! Write line to file
      write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))
    end do

    close(200)

    !---------------------------------------------------------------------------
    write(100,'(A)') 'KVERT'
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Copy elements of inner region from external triangulation
    !---------------------------------------------------------------------------

    open(unit=200, file=trim(adjustl(coutputfile))//'.1.ele')
    read(200, fmt=*) nel

    ! Read element file line by line and convert coordinates
    do iel = 1, nel
      read(200, fmt=*) i, i1, i2, i3

      write(cbuffer1, '(I10)') i1
      write(cbuffer2, '(I10)') i2
      write(cbuffer3, '(I10)') i3

      write(100,'(A)') trim(adjustl(cbuffer1))//' '//&
          trim(adjustl(cbuffer2))//' '//&
          trim(adjustl(cbuffer3))
    end do

    close(200)

    !---------------------------------------------------------------------------
    write(100,'(A)') 'KNPR'
    !---------------------------------------------------------------------------

    ! Write nodal property for boundary vertices
    do ipoint = 1, npoints
      write(100,'(A)') '1'
    end do

    ! Write nodal property for boundary vertices
    do ipoint = npoints+1,nvt
      write(100,'(A)') '0'
    end do

    !---------------------------------------------------------------------------
    write(100,'(A)') 'KMM'
    !---------------------------------------------------------------------------

    write(cbuffer1, '(I10)') 1
    write(cbuffer2, '(I10)') npoints

    write(100,'(A)') trim(adjustl(cbuffer1))//' '//trim(adjustl(cbuffer2))

    close(100)

  end subroutine genTRI

end program gridgenlaval2d


Program G1e11 ! Guia 1 ejercicio 11

! Programa del Ejercicio 11 de la Guia1
! Metodos Numerico 2022
!
!Problema 11: Escriba un programa, que utilizando una subrutina, multiplique un
!  vector de N elementos, por una matriz de N × N.
!El programa debe preguntar el valor de N y luego definir los arreglos, y darle
!  valores iniciales tal que:
!       i. la matriz sea triangular superior, con todos sus elementos igual a 1,
!             excepto los de la diagonal que toman valor 3,
!       ii. el vector tendra todos sus elementos pares igual a 2,
!             y los impares igual a 3.
!No utilice DO para las inicializar el vector, ni DO anidados para inicializar
!  la matriz.
!
!
!           version 1.0
!           4 de abril, 2022
!
! Version original de Osvaldo Moreschi
! Adecuación de Edgardo Bonzi
!             edgardobonzi@gmail.com

USE iso_fortran_env

implicit none

integer :: ii, jj, dim ! Notar que para fortran dim = DIM
integer, parameter :: rl = real128

integer, allocatable, dimension(:,:) :: matA, matB, matC, matD
integer, allocatable, dimension(:)   :: vecE, vecF, vecG

real(rl) :: x    ! Será utilizados al final del programa
real(rl), dimension(5) :: w  ! Será utilizados al final del programa

write(*,*) 'Ingrese la dimensión de los arreglos :'
read(*,*) dim

write (*, 100)
write (*,*) "Dimension dim = ", dim
write (*, 99)

! ====================================================
!     Redimensionamos las matrices y los vectores
! ====================================================

allocate (matA(dim, dim), matB(dim, 1), matC(dim,1), &
          matD(dim, dim), vecE(dim*dim), vecF(dim), vecG(dim))

! ====================================================
!   Jugamos llenando Vector y Matriz Unidimensional
! ====================================================

! Llenamos con 3 y 2 a un vector de dimension dim, [dim] vecG
! ***********************************************************
!
write (*, 100)
vecG(1: dim: 2) = 3 ! Impares: Comienzo en 1, salto de a 2 y lleno con 3
vecG(2: dim: 2) = 2 ! Pares:   Comienzo en 2, salto de a 2 y lleno con 2
write (*, 99)

write (*, 100)
write (*,*) "Vector unidimensional [dim], vecG = "
write (*,*) vecG
write (*, 99)

! Llenamos con 3 y 2 a una matriz unidimensional [dim, 1] matB
! *************************************************************
!
matB(1:dim: 2, 1) = 3 ! Comienzo en 1 y lleno con 3
matB(2:dim: 2, 1) = 2 ! Comienzo en 2 y salto de 2

write (*, 100)
write (*,*) "Matriz unidimensional [dim, 1], matB = "
write (*,*) matB
write (*, 99)

! Probamos distintas formas de escribr matB
write (*, 100)
do ii = 1, dim
   write (*,*) matB(ii, :)
end do
write (*, 99)

write (*, 100)
   write (*,*) matB(:, 1)
write (*, 99)

! Otra manera de hacer la asignación. ( Array Constructors )
! Notar que 'vecF' es un arreglo unidimensional
vecF = (/ ( 2 + mod(ii, 2), ii = 1, dim) /)

write (*, 100)
write (*,*) "Matriz unidimensional [dim, 1], matF = "
write (*,*) vecF
write (*, 99)

! ====================================================
!           Ahora jugamos con la Matriz
! ====================================================
! la matriz sea triangular superior, con todos sus elementos igual a 1, excepto los de
! la diagonal que toman valor 3,

!matA(1:dim,1:dim) = 3 ! Comienzo en 1 y lleno con 3
write (*, 100)
write (*, *) "Sea la matriz triangular superior"
! cargamos los datos en el vector vecE que es dim x dim
vecE = (/ 3, (0, ii = 2, dim), &
       (( 1, ii = 1, jj - 1), 3, (0, ii = jj + 1, dim), jj = 2, dim) /)

write (*,*) 'Vector unidimensional de [dim x dim], vecE ='
do ii = 0, dim-1
  write(*, *) vecE(dim * ii + 1: dim * ( ii + 1))
end do
write (*, 99)

write (*, 100)
 ! se cambia el vector vecE a un arreglo dim x dim matD
matD = reshape ((vecE) ,(/ dim , dim /))
write (*,*) 'Arreglo matD ='
write (*,*)  matD
write (*, 99)

write (*, 100)
do ii = 1, dim
   write (*,*) matD (ii, :)
end do
write(*, 99)
! stop "con todos sus elementos igual a 1, excepto los de la diagonal que toman valor 3"
! Otra manera de hacer la asignacion.

matA = 0

forall (ii = 1: dim, jj = 2: dim, jj > ii) matA(ii, jj) = 1
forall (ii = 1: dim) matA(ii, ii) = 3

write (*,100)
write (*,*) 'MatA(ii, jj) ='
write(*, 99)

write (*,100)
do ii = 1, dim
  write (*,*) matA(ii,:)
end do
write(*, 99)

write (*,100)
write (*,*) 'Arreglo matB ='
write(*,*) matB
write(*, 99)

write (*,100)
matC = matA * matB
write (*,*) 'vector matC = matA * matB :'
write(*,*) matC
write(*, 99)

matC = matmul(matA, matB)
write (*, 100)
write (*,*) 'matC = matmul(matA, matB)'
write (*,*) 'Arreglo matC ='
write(*,*) matC
write (*, 99)

 x = 1.1_rl
 w = (/ 0.0_rl ,x, x-1.0_rl, 0.0_rl, -1.0_rl /)
write (*, 100)
write(*,*) "Valores en w"
write(*,110) w
 ! v = matmul(a,c)

 ! write (*,*) ''

 ! write (*,*) 'matmul(a,c) =', v

 99 Format(' ')
100 Format('------------------------------------------------')
110 Format(5(2X, F10.7))

end program G1e11 ! Guia 1 ejercicio 11


!Crown Copyright 2012 AWE.
!
! This file is part of CloverLeaf.
!
! CloverLeaf 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 3 of the License, or (at your option)
! any later version.
!
! CloverLeaf 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
! CloverLeaf. If not, see http://www.gnu.org/licenses/.

!>  @brief Fortran ideal gas kernel.
!>  @author Wayne Gaudin
!>  @details Calculates the pressure and sound speed for the mesh chunk using
!>  the ideal gas equation of state, with a fixed gamma of 1.4.

MODULE ideal_gas_kernel_module

CONTAINS

SUBROUTINE ideal_gas_kernel(x_min,x_max,y_min,y_max,                &
                            density,                                &
                            energy,                                 &
                            pressure,                               &
                            soundspeed                              )

  IMPLICIT NONE

  INTEGER :: x_min,x_max,y_min,y_max
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2) :: density
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2) :: energy
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2) :: pressure
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2) :: soundspeed

  INTEGER :: j,k

  REAL(KIND=8) :: sound_speed_squared,v,pressurebyenergy,pressurebyvolume

  DO k=y_min,y_max
    DO j=x_min,x_max
      v=1.0_8/density(j,k)
      pressure(j,k)=(1.4_8-1.0_8)*density(j,k)*energy(j,k)
      pressurebyenergy=(1.4_8-1.0_8)*density(j,k)
      pressurebyvolume=-density(j,k)*pressure(j,k)
      sound_speed_squared=v*v*(pressure(j,k)*pressurebyenergy-pressurebyvolume)
      soundspeed(j,k)=SQRT(sound_speed_squared)
    ENDDO
  ENDDO

END SUBROUTINE ideal_gas_kernel

END MODULE ideal_gas_kernel_module


    Program dsyev_example

!     DSYEV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: ddisna, dsyev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eerrbd, eps, r
      Integer :: i, ifail, info, k, lda, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), rcondz(:), w(:), work(:), &
        zerrbd(:)
      Real (Kind=dp) :: dummy(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DSYEV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      Allocate (a(lda,n), rcondz(n), w(n), zerrbd(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dsyev('Vectors', 'Upper', n, a, lda, w, dummy, lwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2)*n, nint(dummy(1)))
      Allocate (work(lwork))

!     Read the upper triangular part of the matrix A from data file

      Read (nin, *)(a(i,i:n), i=1, n)

!     Solve the symmetric eigenvalue problem
      Call dsyev('Vectors', 'Upper', n, a, lda, w, work, lwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)
        Flush (nout)

!       Normalize the eigenvectors: largest element positive
        Do i = 1, n
          Call nagf_blas_damax_val(n, a(1,i), 1, k, r)
          If (a(k,i)<zero) Then
            a(1:n, i) = -a(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
          'Eigenvectors', ifail)

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed eigenvalues.  Note that for
!       the 2-norm, max( abs(W(i)) ) = norm(A), and since the
!       eigenvalues are returned in ascending order
!       max( abs(W(i)) ) = max( abs(W(1)), abs(W(n)))

        eps = epsilon(1.0E0_dp)
        eerrbd = eps*max(abs(w(1)), abs(w(n)))

!       Call DDISNA to estimate reciprocal condition
!       numbers for the eigenvectors
        Call ddisna('Eigenvectors', n, n, w, rcondz, info)

!       Compute the error estimates for the eigenvectors

        Do i = 1, n
          zerrbd(i) = eerrbd/rcondz(i)
        End Do

!       Print the approximate error bounds for the eigenvalues
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimate for the eigenvalues'
        Write (nout, 110) eerrbd
        Write (nout, *)
        Write (nout, *) 'Error estimates for the eigenvectors'
        Write (nout, 110) zerrbd(1:n)
      Else
        Write (nout, 120) 'Failure in DSYEV. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
    End Program


module humidity
    implicit none

    private
    public spec_hum_to_rel_hum
    public rel_hum_to_spec_hum
    public get_qsat

contains
    subroutine spec_hum_to_rel_hum(prog_t, prog_sp, sig, prog_q, rh, qsat)
        real, intent(in) :: prog_t(:)
        real, intent(in) :: prog_sp(:)
        real, intent(in) :: sig
        real, intent(in) :: prog_q(:)
        real, intent(inout) :: rh(:)
        real, intent(inout) :: qsat(:)

        qsat = get_qsat(prog_t, prog_sp, sig)
        rh = prog_q/qsat
    end subroutine spec_hum_to_rel_hum

    subroutine rel_hum_to_spec_hum(prog_t, prog_sp, sig, rh, prog_q, qsat)
        real, intent(in) :: prog_t(:)
        real, intent(in) :: prog_sp(:)
        real, intent(in) :: sig
        real, intent(in) :: rh(:)
        real, intent(inout) :: prog_q(:)
        real, intent(inout) :: qsat(:)

        qsat = get_qsat(prog_t, prog_sp, sig)
        prog_q = rh*qsat
    end subroutine rel_hum_to_spec_hum

    function get_qsat(prog_t, prog_sp, sig) result(qsat)
        real, intent(in) :: prog_t(:)  !! Absolute temperature
        real, intent(in) :: prog_sp(:) !! Normalized pressure (p/1000 hPa)
        real, intent(in) :: sig        !! Sigma level
        real :: qsat(size(prog_t))     !! Saturation specific humidity in g/kg

        real :: e0, c1, c2, t0, t1, t2

        integer :: i

        ! 1. Compute Qsat (g/kg) from T (degK) and normalized pres. P (= p/1000_hPa)
        ! If sig > 0, P = Ps * sigma, otherwise P = Ps(1) = const.
        e0 = 6.108e-3
        c1 = 17.269
        c2 = 21.875
        t0 = 273.16
        t1 = 35.86
        t2 = 7.66

        do i = 1, size(prog_t)
            if (prog_t(i) >= t0) then
                qsat(i) = e0*exp(c1*(prog_t(i) - t0)/(prog_t(i) - t1))
            else
                qsat(i) = e0*exp(c2*(prog_t(i) - t0)/(prog_t(i) - t2))
            end if
        end do

        if (sig <= 0.0) then
            qsat = 622.0*qsat/(prog_sp(1) - 0.378*qsat)
        else
            qsat = 622.0*qsat/(sig*prog_sp - 0.378*qsat)
        end if
    end function get_qsat
end module humidity


module forward_model
  use global_variables
  implicit none

contains

  function Beer(cs, dens) result(y)
    ! Beer-Lambert law
    implicit none
    real(DP), dimension(:,:) :: cs
    real(DP), dimension(:) :: dens
    real(DP), dimension(size(cs,1)) :: y
    y = exp(-matmul(cs,dens*1e5))
  end function Beer

  function Beer_jac(cs, dens) result(j)
    ! Jacobian of the Beer-Lambert law
    implicit none
    real(DP), dimension(:,:), intent(in) :: cs
    real(DP), dimension(:), intent(in) :: dens
    real(DP), dimension(size(cs,1)) :: y
    real(DP), dimension(size(cs,1), size(cs,2)) :: j
    integer :: n
    y = Beer(cs, dens)
    forall (n=1:size(cs,1)) j(n,:) = -cs(n,:)*y(n)
  end function Beer_jac

  function Simulate_meas(cs, dens, noise) result(t)
    ! Simulates a noisy measurement
    use lcg
    implicit none
    real(DP), dimension(:,:), intent(in) :: cs
    real(DP), dimension(:), intent(in) :: dens
    real(DP), intent(in) :: noise
    real(DP), dimension(size(cs,1)) :: t
    call Init_lcg(123123)
    t = Beer(cs, dens) + noise*(sum(Rand_lcg(size(t),12),2)-6.0)
  end function Simulate_meas

  subroutine Init_fmodel(dens, prior, air, alt, cs, wn, csfile, atmosfile)
    ! Read cross-sections, "true" density and prior density profiles
    implicit none
    real(DP), dimension(:,:), allocatable, intent(out) :: cs
    real(DP), dimension(:), allocatable, intent(out) :: dens, air, alt, wn, prior
    character(len=*), intent(in) :: csfile, atmosfile
    integer :: nalt, err, n, nwn, m
    ! alt, dens, air, prior
    open(unit=10, file=atmosfile, status='old')
    nalt = 0
    do
       read(10, *, iostat=err)
       if (err < 0) exit
       nalt = nalt + 1
    end do
    rewind(10)
    allocate(dens(nalt), air(nalt), alt(nalt), prior(nalt))
    do n = 1, nalt
       read(10,*) alt(n), dens(n), air(n), prior(n)
    end do
    close(10)
    ! cross sections
    open(unit=10, file=csfile, status='old')
    nwn = 0
    do
       read(10, *, iostat=err)
       if (err < 0) exit
       nwn = nwn + 1
    end do
    rewind(10)
    allocate(cs(nwn,nalt), wn(nwn))
    do n = 1, nwn
       read(10, *) wn(n), (cs(n,m), m=1, nalt)
    end do
    close(10)
  end subroutine Init_fmodel

end module forward_model


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_cover_sph( n, c1, gg1, c2, gg2, shrink, c, gg )

!  Given a pair of ellipsoids, E1 and E2, determine a third ellipsoid
!  E (specifically a spheroid) which covers E1 and E2.
!  E is defined by:  (x-c)^T * G * G^T * (x-c) <= 1, where the array gg
!  contains G in packed format.  Similarly for E1 and E2.
!  A = G * G^T, A1 = G1 * G1^T, A2 = G2 * G2^T

!  Method:
!     Determine ball which covers bounding balls of E1 and E2.
!     Optionally shrink ball as much as possible (if shrink true).

!  S.B. Pope  7/3/2006, 11/25/2006

implicit none

integer,    parameter   :: k_dp = kind(1.d0)
integer,    intent(in)  :: n
real(k_dp), intent(in)  :: c1(n), gg1((n*(n+1))/2), c2(n), gg2((n*(n+1))/2)
logical,    intent(in)  :: shrink
real(k_dp), intent(out) :: c(n),  gg((n*(n+1))/2)

real(k_dp), parameter   :: extend = 1.d-6   !  small amount to extend radius to ensure covering

integer    :: i, j, k
real(k_dp) :: d, r1, r2, r, smin, smax, dc(n), zero(n), xfar(n)

d	= sqrt( sum( (c2-c1)*(c2-c1) ) )  ! distance between centers
call ell_radii( n, gg1, r, r1 )       ! radius of ball covering E1
call ell_radii( n, gg2, r, r2 )       ! radius of ball covering E2

!  Consider line of centers, with distance s measured from c1 towards c2.
!  Thus c2 corresponds to s = d.

smin = min( -r1, -r2 + d )  !  intersections of E with line
smax = max(  r1,  r2 + d )

c = c1  !  set c to correspond to (smin+smax)/2
if( d > 0.d0 ) then
   c = c1 + 0.5d0*(smin+smax)*(c2-c1)/d
endif

if( shrink ) then
   zero = 0.d0  !  find furthest point in E1 from c
   dc   = c1 - c
   call ell_pt_near_far( 2, n, dc, gg1, zero, xfar )
   r1 = sum( xfar*xfar)

   dc   = c2 - c !  find furthest point in E2 from c
   call ell_pt_near_far( 2, n, dc, gg2, zero, xfar )
   r2 = sum( xfar*xfar)

   r  = sqrt( max(r1,r2) )  ! set r to max. distance from c
else
   r = 0.5d0*(smax-smin)
endif

r = (1.d0 - extend) / r  !  diagonal components of G = 1/r

k  = 0  !  G into gg
gg = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  if( i==j ) gg(k) = r
   end do
end do

return
end subroutine ell_pair_cover_sph


      subroutine afree(ndata,a,inca,g,incg,gssq)
c-------------------------------------------------------------------
c        imposes constraint on weights a such that the inner
c  product of vector a and gsurf is unity.  useful routine for
c  adding constraint in inverse problem using integration
c  quelling to allow value of the model at 0 to be a free parameter.
c
c  arguments-
c
c    ndata - length of vectors a and g
c    a     - array of weights that are to be rescaled to satisfy
c            constraint.
c    inca  - storage increment of a array ala blas.  use 1 if
c            a is stored in column fashion.  use first dimension
c            of a if values are stored in rows of a two dimensional
c            array.
c    g     - constraint vector of length ndata.  in inversion
c            this is the value of all data kernels at 0.
c    incg  - storage increment of g array ala blas.  (see above)
c    gssq  - square of l2 norm of gsurf array.  passed for
c            efficiency reason as this routine is expected
c            normally to be called several times within a loop
c            over several sets of weight vectors, a.
c
c  language - 1977 ansi standard fortran
c  author   - gary l. pavlis
c  required software support - library containing blas
c  written  - april 1981
c-------------------------------------------------------------------
      real a(ndata),g(ndata)
      real gssq
      integer ndata
      real alm
      alm = (sdot(ndata,a,inca,g,incg) - 1.0)/gssq
      call saxpy(ndata,-alm,g,incg,a,inca)
      return
      end

c $Id$


module mod_define_explicit_RK_methods
! Module containing subroutines and functions defining various explicit Runge-Kutta methods
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO,ONE,TWO,THREE,EIGHTH,SIXTH,FOURTH,THIRD,HALF,TWO_THR
    implicit none

    !!
    !! The equation to be solved here is
    !!
    !! \f$ \frac{\partial Q}{\partial t} + R(Q) = 0 \f$
    !!
    !! The discretization is given as
    !!
    !! \f$ Q^{n + 1} = Q^{n} + \Delta Q \f$
    !!
    !! where
    !!
    !! \f$ \Delta Q = \sum_{i = 1}^{s} b_{i} \Delta Q_{i} \f$
    !!
    !! with \f$ s \f$ being the number of stages in the method and
    !!
    !! \f$ \Delta Q_{i} = -\Delta t M^{-1} R(Q^{n} + \sum_{j = 1}^{i - 1} a_{ij} \Delta Q_{j} \f$
    !!
    !! Butcher tableau notation has been followed here
    !!
contains

    !> Define Runge's method (2nd order method with two stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine runge_2nd_order(nstage,a,b)
        integer(ik),            intent(inout)        :: nstage
        real(rk),   allocatable,intent(inout)        :: a(:,:)
        real(rk),   allocatable,intent(inout)        :: b(:)

        !
        ! Set number of stages
        !
        nstage = 2

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = HALF

        b = [ZERO, ONE]

    end subroutine runge_2nd_order
    !***************************************************************************************************

    !> Define Heun's method (2nd order method with two stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine heun_2nd_order(nstage,a,b)
        integer(ik),            intent(inout)       :: nstage
        real(rk),   allocatable,intent(inout)       :: a(:,:)
        real(rk),   allocatable,intent(inout)       :: b(:)

        !
        ! Set number of stages
        !
        nstage = 2

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = ONE

        b = [HALF,HALF]

    end subroutine heun_2nd_order
    !***************************************************************************************************

    !> Define Ralston's method (2nd order method with two stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine ralston_2nd_order(nstage,a,b)
        integer(ik),            intent(inout)       :: nstage
        real(rk),   allocatable,intent(inout)       :: a(:,:)
        real(rk),   allocatable,intent(inout)       :: b(:)

        !
        ! Set number of stages
        !
        nstage = 2

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = TWO_THR

        b = [FOURTH,THREE*FOURTH]

    end subroutine ralston_2nd_order
    !***************************************************************************************************

    !> Define Kutta's method (3rd order method with three stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine kutta_3rd_order(nstage,a,b)
        integer(ik),            intent(inout)       :: nstage
        real(rk),   allocatable,intent(inout)       :: a(:,:)
        real(rk),   allocatable,intent(inout)       :: b(:)

        !
        ! Set number of stages
        !
        nstage = 3

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = HALF; a(3,1) = -ONE; a(3,2) = TWO

        b = [SIXTH,TWO_THR,SIXTH]

    end subroutine kutta_3rd_order
    !***************************************************************************************************

    !> Define the Runge-Kutta  method (4th order method with four stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine runge_kutta_4th_order(nstage,a,b)
        integer(ik),            intent(inout)       :: nstage
        real(rk),   allocatable,intent(inout)       :: a(:,:)
        real(rk),   allocatable,intent(inout)       :: b(:)

        !
        ! Set number of stages
        !
        nstage = 4

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = HALF; a(3,2) = HALF; a(4,3) = ONE

        b = [SIXTH,THIRD,THIRD,SIXTH]

    end subroutine runge_kutta_4th_order
    !***************************************************************************************************

    !> Define the 3/8-rule method (4th order method with four stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/17/2017
    !!
    !! @param[out]  nstage - Number of stages in the present method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine three_eighth_4th_order(nstage,a,b)
        integer(ik),            intent(inout)       :: nstage
        real(rk),   allocatable,intent(inout)       :: a(:,:)
        real(rk),   allocatable,intent(inout)       :: b(:)

        !
        ! Set number of stages
        !
        nstage = 4

        if (allocated(a) .and. allocated(b)) deallocate(a,b)
        allocate(a(nstage,nstage),b(nstage))

        !
        ! a is a lower triangular matrix
        !
        a      = ZERO
        a(2,1) = THIRD
        a(3,1) = -THIRD; a(3,2) = ONE
        a(4,1) = ONE; a(4,2) = -ONE; a(4,3) = ONE

        b = [EIGHTH,THREE*EIGHTH,THREE*EIGHTH,EIGHTH]

    end subroutine three_eighth_4th_order
    !***************************************************************************************************

    !> Select explicit Runge-Kutta method based on input
    !!
    !! @author Mayank Sharma
    !! @date   1/23/2017
    !!
    !! @param[in]   time_scheme - String denoting the method to be used from user input
    !! @param[out]  nstage      - Number of stages in the selected method
    !! @param[out]  a           - Array of coefficients for calculating stagewise updates
    !! @param[out]  b           - Array of coefficients for summing stagewise updates to get final update
    !!
    !---------------------------------------------------------------------------------------------------
    subroutine method_selector(time_scheme,nstage,a,b)
        character(len = :), allocatable, intent(in)     :: time_scheme
        integer(ik),                     intent(inout)  :: nstage
        real(rk),           allocatable, intent(inout)  :: a(:,:)
        real(rk),           allocatable, intent(inout)  :: b(:)

        select case(time_scheme)

            case('Second Order Runge-Kutta', 'Explicit Midpoint', 'Second Order RK')
                call runge_2nd_order(nstage,a,b)

            case('Modified Euler', 'Second Order Heun Method')
                call heun_2nd_order(nstage,a,b)

            case('Ralston Method', 'Second Order Ralston Method')
                call ralston_2nd_order(nstage,a,b)

            case('Third Order Runge-Kutta', 'Third Order Kutta', 'Third Order RK')
                call kutta_3rd_order(nstage,a,b)

            case('Runge-Kutta Method', 'Fourth Runge-Kutta Method', 'Fourth Order RK Method', 'RK4')
                call runge_kutta_4th_order(nstage,a,b)

            case('Three-Eighth Rule', 'Fourth Order Kutta')
                call three_eighth_4th_order(nstage,a,b)

        end select

    end subroutine method_selector
    !***************************************************************************************************

end module mod_define_explicit_RK_methods


module init_mod
  use helpers_mod
  implicit none

  contains

  subroutine init_flag(delx, dely, flag, ibound)
    real, intent(in) :: delx, dely
    integer flag(0:imax+1, 0:jmax+1)

    real :: mx, my, x, y, rad1, x1, y1
    integer :: ibound;

    integer :: i, j

    ! mask of a circular obstacle
    mx = 20.0/41.0*jmax*dely
    my = mx
    rad1 = 5.0/41.0*jmax*dely

    flag = C_F

    ! insert circular mask
    do i = 1, imax
      do j = 1, jmax
        x = (i-0.5)*delx - mx
        y = (j-0.5)*dely - my
        if (x*x + y*y <= rad1*rad1) then
          flag(i,j) = C_B
        end if

        ! Some code for adding a few more circular masks near-by
        !x1 = (i-0.5)*delx - mx*4
        !y1 = (j-0.5)*dely - my*1.25
        !if (x1*x1 + y1*y1 <= rad1*rad1) then
        !   flag(i,j) = C_B
        !end if
        !
        !x1 = (i-0.5)*delx - mx*3
        !y1 = (j-0.5)*dely - my*0.5
        !if (x1*x1 + y1*y1 <= rad1*rad1) then
        !   flag(i,j) = C_B
        !end if
      end do
    end do

    ! mark east & west bounary cells
    flag(0:imax+1,0) = C_B
    flag(0:imax+1,jmax+1) = C_B
    ! mark north & south boundary cells as obstacles
    flag(0,1:jmax) = C_B
    flag(imax+1,1:jmax) = C_B

    do i = 1, imax
      do j = 1, jmax
        if (.not. (toLogical (iand(flag(i,j),C_F)))) then
          ibound = ibound + 1
          if (toLogical (iand(flag(i-1,j), C_F))) flag(i,j) = ior(flag(i,j), B_W)
          if (toLogical (iand(flag(i+1,j), C_F))) flag(i,j) = ior(flag(i,j), B_E)
          if (toLogical (iand(flag(i,j-1), C_F))) flag(i,j) = ior(flag(i,j), B_S)
          if (toLogical (iand(flag(i,j+1), C_F))) flag(i,j) = ior(flag(i,j), B_N)
        end if
      end do
    end do
  end subroutine init_flag
end module init_mod


program ch0505
    ! Relative and Absolute Error
    implicit none

    real :: p = 0.4e-4, papprox = 0.41e-4
    real :: abs_error, rel_error
    integer :: i

    do i = 1, 3
        abs_error = abs(p-papprox)
        rel_error = abs(p-papprox)/abs(p)
        print 100, p, papprox
        print 110, abs_error, rel_error
        p = p*1.e5
        papprox = papprox*1.e5
    end do

100 format (' p       = ', e11.4, /, &
    'papprox = ', e11.4)
110 format (' abs error:', 12x, e11.4, /, &
    'rel error:', 12x, e11.4, /)
end program


      double precision function vol3_mass(decaymass,s)
      implicit none
      double precision decaymass,b0,bp,bm,s,ro,vol
c  Volume of phase space for 2-->p3(decaymass)+p4(decaymass)+p5(0)
      if (decaymass .eq. 0d0) then
      vol3_mass=1d0
      else
      ro=4d0*decaymass**2/s
      b0=dsqrt(1d0-ro)
      bp=0.5d0*(1d0+b0)
      bm=0.5d0*(1d0-b0)

      vol3_mass=(3d0-b0**2)/2d0*b0
     . -(1d0-b0**2)*(3d0+b0**2)/4d0*log(bp/bm)
      endif
      vol3_mass=vol3_mass*vol(s,3)
      return
      end


!------------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in           !
!  continuous development by various groups and is based on information        !
!  from these groups: Federal Government employees, contractors working        !
!  within a United States Government contract, and non-Federal sources         !
!  including research institutions.  These groups give the Government          !
!  permission to use, prepare derivative works of, and distribute copies       !
!  of their work in the CMAQ system to the public and to permit others         !
!  to do so.  The United States Environmental Protection Agency                !
!  therefore grants similar permission to use the CMAQ system software,        !
!  but users are requested to provide copies of derivative works or            !
!  products designed to operate in the CMAQ system to the United States        !
!  Government without restrictions as to use by others.  Software              !
!  that is used with the CMAQ system but distributed under the GNU             !
!  General Public License or the GNU Lesser General Public License is          !
!  subject to their copyright restrictions.                                    !
!------------------------------------------------------------------------------!

SUBROUTINE xy2ll_merc (xx, yy, lambda0, phi, lambda)

!-------------------------------------------------------------------------------
! Name:     (X,Y) to Latitude-Longitude for Polar Stereographic Projection
! Purpose:  Calcluates latitude-longitude for a given (X,Y) pair from origin
!           and polar stereographic projection information.
! Notes:    Equations taken from "Map Projections: Theory and Applications"
!           by Frederick Pearson, II (1990), pp. 190-192.
! Revised:  18 Sep 2009  Original version.  (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!-------------------------------------------------------------------------------

  USE const, ONLY: rearth

  IMPLICIT NONE

  REAL(8)                      :: deg2rad    ! convert degrees to radians
  REAL(8)                      :: drearth    ! earth radius [m]
  REAL,          INTENT(OUT)   :: lambda     ! longitude [deg]
  REAL(8)                      :: lambdarad  ! longitude [rad]
  REAL,          INTENT(IN)    :: lambda0    ! center longitude [deg]
  REAL(8)                      :: lambda0rad ! center longitude [rad]
  REAL,          INTENT(OUT)   :: phi        ! latitude [deg]
  REAL(8)                      :: phirad     ! latitude [rad]
  REAL(8)                      :: pi
  REAL(8)                      :: piover2    ! pi/2
  REAL(8)                      :: piover4    ! pi/4
  REAL(8)                      :: rad2deg
  REAL,          INTENT(IN)    :: xx         ! X-coordinate from origin
  REAL(8)                      :: xxd
  REAL,          INTENT(IN)    :: yy         ! Y-coordinate from origin
  REAL(8)                      :: yyd

!-------------------------------------------------------------------------------
! Compute constants.
!-------------------------------------------------------------------------------

  piover4 = DATAN(1.0d0)
  piover2 = 2.0d0 * piover4
  pi      = 4.0d0 * piover4
  deg2rad = pi / 1.8d2
  rad2deg = 1.8d2 / pi

  drearth = DBLE(rearth)

!-------------------------------------------------------------------------------
! Set up geometric constants.
!-------------------------------------------------------------------------------

  xxd  = DBLE(xx)
  yyd  = DBLE(yy)

!-------------------------------------------------------------------------------
! Compute latitude (PHI).
!-------------------------------------------------------------------------------

  phirad  = ( 2.0d0 * DATAN ( DEXP(yyd/drearth) ) ) - piover2
  phi     = REAL( phirad * rad2deg )

!-------------------------------------------------------------------------------
! Compute longitude (LAMBDA).
!-------------------------------------------------------------------------------

  lambda0rad = DBLE(lambda0) * deg2rad
  lambdarad  = lambda0rad + xxd/drearth
  lambda     = REAL( lambdarad * rad2deg )

END SUBROUTINE xy2ll_merc


PROGRAM test_fftw
  USE general_tools
  USE cs_tools
  USE debug_tools
  USE fftw_tools
IMPLICIT NONE

  INTEGER, PARAMETER :: IP_SIZE = 512
  INTEGER :: ibi
  REAL(cp) :: rp_scale = 3.0
  REAL(cp) :: rl_nz_ratio
  real(C_DOUBLE) :: rl_dx
  type(C_PTR) :: plan_forward, plan_backward
  real(C_DOUBLE), dimension(IP_SIZE) :: rla_x, rla_y, rla_in, rla_out, rla_signal, rla_fft_coef
  TYPE(dyn_rVector), DIMENSION(5) :: tla_save

  CALL init_all()

  rl_dx = 2.0*rp_pi/(IP_SIZE-1)
  rla_x = (/ ((ibi-1)*rl_dx, ibi=1,IP_SIZE) /)
  tla_save(1) = rla_x
  rla_fft_coef = 0.0_cp
  rla_signal   = 0.0_cp
  rl_nz_ratio  = 0.1
  CALL RANDOM_NUMBER(rla_fft_coef)
  rla_fft_coef = rp_scale*(rla_fft_coef - 0.5_cp)
  CALL randval_randidx(rla_fft_coef, rl_nz_ratio, rp_scale)
  tla_save(3) = rla_fft_coef
  CALL ifftw_trans(rla_fft_coef, rla_signal)
  tla_save(2) = rla_signal
  CALL RANDOM_NUMBER(rla_signal)
  rla_signal = rp_scale*(rla_signal - 0.5_cp)
  CALL randval_randidx(rla_signal, rl_nz_ratio, rp_scale)
  tla_save(4) = rla_signal
  CALL fftw_trans(rla_signal, rla_fft_coef)
  tla_save(5) = rla_fft_coef
  CALL save_trj( tla_save(1:5) , TRIM('output/test.dat' ), ld_column = .TRUE. )

  CALL finalize_all()
CONTAINS

  SUBROUTINE init_all()
    CALL init_fftw()
    CALL init_cs_tools()
  END SUBROUTINE init_all

  SUBROUTINE finalize_all()
    CALL finalize_fftw()
    CALL finalize_cs_tools()
  END SUBROUTINE finalize_all

  SUBROUTINE test()
    !complex(C_DOUBLE_COMPLEX), dimension(IP_SIZE/2 + 1) :: cla_out
    !fftw_plan fftw_plan_r2r_1d(int n, double *in, double *out, fftw_r2r_kind kind, unsigned flags); FFTW_R2HC/FFTW_HC2R
    rl_dx = 2.0*rp_pi/(IP_SIZE-1)
    DO ibi=1, IP_SIZE
      rla_x(ibi) = (ibi-1)*rl_dx!-rp_pi
    END DO
    rla_y = cos(22*rla_x) -cos(40*rla_x)! - sin(16*rla_x)
    tla_save(1) = rla_x
    tla_save(2) = rla_y
    plan_forward  = fftw_plan_r2r_1d(IP_SIZE, rla_in , rla_out, FFTW_R2HC, FFTW_ESTIMATE)
    plan_backward = fftw_plan_r2r_1d(IP_SIZE, rla_out, rla_in , FFTW_HC2R, FFTW_ESTIMATE)
    !...
    rla_in = rla_y
    call fftw_execute_r2r(plan_forward , rla_in, rla_out)
    rla_out = rla_out/SQRT(IP_SIZE*1.0_cp)
    tla_save(3) = rla_out
    rla_in = 0.0_cp
    WHERE (ABS(rla_out)<MAXVAL(rla_out)/10.0_cp) rla_out=0.0_cp
    tla_save(4) = rla_out
    call fftw_execute_r2r(plan_backward, rla_out, rla_in)
    rla_in = rla_in/SQRT(IP_SIZE*1.0_cp)
    tla_save(5) = rla_in
    !...
    !...
    call fftw_destroy_plan(plan_forward )
    call fftw_destroy_plan(plan_backward)
    CALL save_trj( tla_save , TRIM('output/fft.dat' ), ld_column = .TRUE. )
  END SUBROUTINE test
END PROGRAM test_fftw