NAG Library Manual, Mark 28.7
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   D06BAF Example Program Text
!   Mark 28.7 Release. NAG Copyright 2022.
    Module d06bafe_mod

!     D06BAF Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: fbnd
!     .. Parameters ..
      Integer, Parameter, Public       :: nin = 5, nout = 6
    Contains
      Function fbnd(i,x,y,ruser,iuser)

!       .. Function Return Value ..
        Real (Kind=nag_wp)             :: fbnd
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: x, y
        Integer, Intent (In)           :: i
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: radius2, x0, xa, xb, y0
!       .. Executable Statements ..
        xa = ruser(1)
        xb = ruser(2)
        x0 = ruser(3)
        y0 = ruser(4)

        fbnd = 0.0_nag_wp

        Select Case (i)
        Case (1)

!         line 1,2,3, and 4: ellipse centred in (X0,Y0) with
!         XA and XB as coefficients

          fbnd = ((x-x0)/xa)**2 + ((y-y0)/xb)**2 - 1.0_nag_wp
        Case (2)

!         line 7, lower arc on letter n, is a circle centred in (X0,Y0)
!         with radius SQRT(RADIUS2)

          x0 = 0.5_nag_wp
          y0 = 6.25_nag_wp
          radius2 = 20.3125_nag_wp
          fbnd = (x-x0)**2 + (y-y0)**2 - radius2
        Case (3)

!         line 11, upper arc on letter n, is a circle centred in (X0,Y0)
!         with radius SQRT(RADIUS2)

          x0 = 1.0_nag_wp
          y0 = 4.0_nag_wp
          radius2 = 9.0_nag_wp + (11.0_nag_wp-y0)**2
          fbnd = (x-x0)**2 + (y-y0)**2 - radius2
        Case (4)

!         line 15, upper arc on letter a, is a circle centred in (X0,Y0)
!         with radius SQRT(RADIUS2) touching point (5,11).

          x0 = 8.5_nag_wp
          y0 = 2.75_nag_wp
          radius2 = (x0-5.0_nag_wp)**2 + (11.0_nag_wp-y0)**2
          fbnd = (x-x0)**2 + (y-y0)**2 - radius2
        Case (5)

!         line 25, lower arc on hat of 'a', is a circle centred in (X0,Y0)
!         with radius SQRT(RADIUS2) touching point (11,10).

          x0 = 8.5_nag_wp
          y0 = 4.0_nag_wp
          radius2 = 2.5_nag_wp**2 + (10.0_nag_wp-y0)**2
          fbnd = (x-x0)**2 + (y-y0)**2 - radius2
        Case (6)

!         lines 20, 21 and 22, belly of letter a, is an ellipse centered
!         in (X0, Y0) with semi-axes 3.5 and 2.75.

          x0 = 8.5_nag_wp
          y0 = 5.75_nag_wp
          fbnd = ((x-x0)/3.5_nag_wp)**2 + ((y-y0)/2.75_nag_wp)**2 - 1.0_nag_wp
        Case (7)

!         lines 43, 44 and 45, outer curve on bottom of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 3.5 and 2.5.

          x0 = 17.5_nag_wp
          y0 = 2.5_nag_wp
          fbnd = ((x-x0)/3.5_nag_wp)**2 + ((y-y0)/2.5_nag_wp)**2 - 1.0_nag_wp
        Case (8)

!         lines 28, 29 and 30, inner curve on bottom of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 2.0 and 1.5.

          x0 = 17.5_nag_wp
          y0 = 2.5_nag_wp
          fbnd = ((x-x0)/2.0_nag_wp)**2 + ((y-y0)/1.5_nag_wp)**2 - 1.0_nag_wp
        Case (9)

!         line 42, inner curve on lower middle of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 1.5 and 0.5.

          x0 = 17.5_nag_wp
          y0 = 5.5_nag_wp
          fbnd = ((x-x0)/1.5_nag_wp)**2 + ((y-y0)/0.5_nag_wp)**2 - 1.0_nag_wp
        Case (10)

!         line 31, outer curve on lower middle of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 2.0 and 1.5.

          x0 = 17.5_nag_wp
          y0 = 5.5_nag_wp
          fbnd = ((x-x0)/3.0_nag_wp)**2 + ((y-y0)/1.5_nag_wp)**2 - 1.0_nag_wp
        Case (11)

!         line 41, inner curve on upper middle of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 1.0 and 1.0.

          x0 = 17.0_nag_wp
          y0 = 5.5_nag_wp
          fbnd = ((x-x0)/1.0_nag_wp)**2 + ((y-y0)/1.0_nag_wp)**2 - 1.0_nag_wp
        Case (12)

!         line 32, outer curve on upper middle of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 1.5 and 1.1573.

          x0 = 16.0_nag_wp
          y0 = 5.5_nag_wp
          fbnd = ((x-x0)/1.5_nag_wp)**2 + ((y-y0)/1.1573_nag_wp)**2 -          &
            1.0_nag_wp
        Case (13)

!         lines 33, 33, 34, 39 and 40, upper portion of 'g', is an ellipse
!         centered in (X0, Y0) with semi-axes 3.0 and 2.75.
          x0 = 17.0_nag_wp
          y0 = 9.25_nag_wp
          fbnd = ((x-x0)/3.0_nag_wp)**2 + ((y-y0)/2.75_nag_wp)**2 - 1.0_nag_wp
        End Select

        Return

      End Function fbnd
    End Module d06bafe_mod
    Program d06bafe

!     D06BAF Example Main Program

!     .. Use Statements ..
      Use d06bafe_mod, Only: fbnd, nin, nout
      Use nag_library, Only: d06abf, d06acf, d06baf, f16dnf, nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: x0, xa, xb, xmax, xmin, y0, ymax,    &
                                          ymin
      Integer                          :: i, ifail, itrace, j, k, liwork,      &
                                          lrwork, maxind, maxval, ncomp,       &
                                          nedge, nedmx, nelt, nlines, npropa,  &
                                          nv, nvb, nvint, nvmax, reftk, sdcrus
      Character (1)                    :: pmesh
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: coor(:,:), coorch(:,:), crus(:,:),   &
                                          rate(:), rwork(:), weight(:)
      Real (Kind=nag_wp)               :: ruser(4)
      Integer, Allocatable             :: conn(:,:), edge(:,:), iwork(:),      &
                                          lcomp(:), lined(:,:), nlcomp(:)
      Integer                          :: iuser(1)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: abs
!     .. Executable Statements ..
      Write (nout,*) 'D06BAF Example Program Results'
      Flush (nout)

!     Skip heading in data file
      Read (nin,*)

!     Initialize boundary mesh inputs:
!     the number of line and of the characteristic points of
!     the boundary mesh

      Read (nin,*) nlines, nvmax, nedmx
      Allocate (coor(2,nvmax),coorch(2,nlines),rate(nlines),edge(3,nedmx),     &
        lcomp(nlines),lined(4,nlines))

!     The Lines of the boundary mesh

      Read (nin,*)(lined(1:4,j),rate(j),j=1,nlines)

      sdcrus = 0

      Do i = 1, nlines

        If (lined(4,i)<0) Then
          sdcrus = sdcrus + lined(1,i) - 2
        End If

      End Do

      liwork = 8*nlines + nvmax + 3*nedmx + 3*sdcrus

!     Get max(LINED(1,:)) for computing LRWORK

      Call f16dnf(nlines,lined,4,maxind,maxval)

      lrwork = 2*(nlines+sdcrus) + 2*maxval*nlines

      Allocate (crus(2,sdcrus),iwork(liwork),rwork(lrwork))

!     The ellipse boundary which envelops the NAG Logo
!     the N, the A and the G

      Read (nin,*) coorch(1,1:nlines)
      Read (nin,*) coorch(2,1:nlines)

      Read (nin,*) crus(1,1:sdcrus)
      Read (nin,*) crus(2,1:sdcrus)

!     The number of connected components to the boundary
!     and their information

      Read (nin,*) ncomp
      Allocate (nlcomp(ncomp))

      j = 1

      Do i = 1, ncomp
        Read (nin,*) nlcomp(i)
        k = j + abs(nlcomp(i)) - 1
        Read (nin,*) lcomp(j:k)
        j = k + 1
      End Do

!     Data passed to the user-supplied function

      xmin = coorch(1,4)
      xmax = coorch(1,2)
      ymin = coorch(2,1)
      ymax = coorch(2,3)

      xa = (xmax-xmin)/2.0_nag_wp
      xb = (ymax-ymin)/2.0_nag_wp

      x0 = (xmin+xmax)/2.0_nag_wp
      y0 = (ymin+ymax)/2.0_nag_wp

      ruser(1:4) = (/xa,xb,x0,y0/)
      iuser(1) = 0

      itrace = -1

      Write (nout,*)
      Flush (nout)

!     Call to the boundary mesh generator

      ifail = 0
      Call d06baf(nlines,coorch,lined,fbnd,crus,sdcrus,rate,ncomp,nlcomp,      &
        lcomp,nvmax,nedmx,nvb,coor,nedge,edge,itrace,ruser,iuser,rwork,lrwork, &
        iwork,liwork,ifail)

      Read (nin,*) pmesh

      Select Case (pmesh)
      Case ('N')
        Write (nout,*) 'Boundary mesh characteristics'
        Write (nout,99999) 'NVB   =', nvb
        Write (nout,99999) 'NEDGE =', nedge
      Case ('Y')

!       Output the mesh

        Write (nout,99998) nvb, nedge

        Do i = 1, nvb
          Write (nout,99997) i, coor(1:2,i)
        End Do

        Do i = 1, nedge
          Write (nout,99996) i, edge(1:3,i)
        End Do

        Flush (nout)

      Case Default
        Write (nout,*) 'Problem with the printing option Y or N'
        Go To 100
      End Select

      Deallocate (rwork,iwork)

!     Initialize mesh control parameters

      itrace = 0
      npropa = 1
      nvint = 0
      lrwork = 12*nvmax + 15
      liwork = 6*nedge + 32*nvmax + 2*nvb + 78
      Allocate (weight(nvint),rwork(lrwork),iwork(liwork),conn(3,2*nvmax+5))

!     Call to the 2D Delaunay-Voronoi mesh generator

      ifail = 0
      Call d06abf(nvb,nvint,nvmax,nedge,edge,nv,nelt,coor,conn,weight,npropa,  &
        itrace,rwork,lrwork,iwork,liwork,ifail)

      Select Case (pmesh)
      Case ('N')
        Write (nout,*) 'Complete mesh (via the 2D Delaunay-Voronoi'
        Write (nout,*) 'mesh generator) characteristics'
        Write (nout,99999) 'NV (rounded to nearest 10)   =', 10*((nv+5)/10)
        Write (nout,99999) 'NELT (rounded to nearest 10) =', 10*((nelt+5)/10)
      Case ('Y')

!       Output the mesh

        Write (nout,99998) nv, nelt

        Do i = 1, nv
          Write (nout,99995) coor(1:2,i)
        End Do

        reftk = 0

        Do k = 1, nelt
          Write (nout,99994) conn(1:3,k), reftk
        End Do

        Flush (nout)

      End Select

      Deallocate (rwork,iwork)
      lrwork = 12*nvmax + 30015
      liwork = 8*nedge + 53*nvmax + 2*nvb + 10078
      Allocate (rwork(lrwork),iwork(liwork))

!     Call to the 2D Advancing front mesh generator

      ifail = 0
      Call d06acf(nvb,nvint,nvmax,nedge,edge,nv,nelt,coor,conn,weight,itrace,  &
        rwork,lrwork,iwork,liwork,ifail)

      Select Case (pmesh)
      Case ('N')
        Write (nout,*) 'Complete mesh (via the 2D Advancing front mesh'
        Write (nout,*) 'generator) characteristics'
        Write (nout,99999) 'NV (rounded to nearest 10)   =', 10*((nv+5)/10)
        Write (nout,99999) 'NELT (rounded to nearest 10) =', 10*((nelt+5)/10)
      Case ('Y')

!       Output the mesh

        Write (nout,99998) nv, nelt

        Do i = 1, nv
          Write (nout,99995) coor(1:2,i)
        End Do

        reftk = 0

        Do k = 1, nelt
          Write (nout,99994) conn(1:3,k), reftk
        End Do

      End Select

100   Continue

99999 Format (1X,A,I6)
99998 Format (1X,2I10)
99997 Format (2X,I4,2(2X,E13.6))
99996 Format (1X,4I4)
99995 Format (2(2X,E13.6))
99994 Format (1X,4I10)
    End Program d06bafe