!
!     ---------------------------------------------------------------
!
PROGRAM gengrid
  !
  !     Program to generate a cubed sphere grid, including cross-
  !     reference tables of adjacent faces, edges and vertices,
  !     coordinates of faces and vertices, and lengths of edges
  !     and areas of faces.
  !
  !             .....
  !            :  3  |
  !            :     |
  !             -----
  !      -----  .....  .....  -----
  !     |  5  :|  1  :|  2  :|  4  :
  !     |     :|     :|     :|     :
  !      .....  -----  -----  .....
  !             .....
  !            |  6  :
  !            |     :
  !             -----
  !
  !     Solid lines: left and bottom edges of panel
  !     Dotted lines: right and top edges of panel
  !
  !     John Thuburn Nov 2011
  !
  !     ---------------------------------------------------------------

  USE grid

  IMPLICIT NONE

  INTEGER :: igrid, i, j, ixv, p1, p2, pp, jr, iv, iv0, n, n2, &
       ie0, ie1, ie2, if0, if1, if2, if3, iv1, iv2, ix1, ix2, &
       ixmin, ifmin, if21, if22, iv11, iv12, iv21, iv22, &
       ismooth

  REAL*8 :: dlambda, lambda1, lambda2, t1, t2, long, lat, &
       x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4, &
       x5, y5, z5, x6, y6, z6, piby4, xc, yc, zc, x0, y0, z0, &
       rmag, atri, aface, lmn, lmx, dmn, dmx, dav, cs, s, &
       theta, thetamin, sn, d1x, d1y, d1z, d2x, d2y, d2z

  CHARACTER (LEN=56) :: yname, atmp

  CHARACTER*56 :: ygridfile

  LOGICAL :: lfound

  ! Pi
  REAL*8, PARAMETER :: pi = 3.14159265358979323d0

  !Degrees to radians coversion (multiply to obtain conversion)
  REAL*8, PARAMETER :: deg2rad = pi / 180.0d0

  !Radians to Degrees coversion (multiply to obtain conversion)
  REAL*8, PARAMETER :: rad2deg = 1.0d0/deg2rad

!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! PROGRAM ARGUMENTS

  CHARACTER*127 :: argLevels
  INTEGER :: levels

  IF (IARGC() < 1) THEN
     WRITE (*,*) "Usage: ./gengrid_cube [levels > 0]"
     CALL EXIT(-1)
  END IF

  CALL GETARG(1, argLevels)
  READ (argLevels, '(i10)') levels

  ! update variables in grid module
  ngrids = levels

  ! n x n cells on each panel
  ! Smallest and largest n

  if(ngrids > 0 )then
     n0 = 3
  else
     n0=1
     ngrids=1
  endif
  nl = n0*(2**(ngrids-1))

  nx2 = nl*nl

  nfacex = 6*nl*nl
  nedgex = 2*nfacex
  nvertx = nfacex + 2
  !print*, nl, nfacex, nedgex

  ALLOCATE(neoff(nfacex,ngrids), neofv(nvertx,ngrids), &
       nface(ngrids), nedge(ngrids), nvert(ngrids))
  ALLOCATE(fnxtf(nfacex,4,ngrids), eoff(4,nfacex,ngrids), &
       voff(nfacex,4,ngrids), fnxte(2,nedgex,ngrids), &
       vofe(2,nedgex,ngrids), fofv(nvertx,4,ngrids), &
       eofv(4,nvertx,ngrids))
  ALLOCATE(flong(nfacex,ngrids), flat(nfacex,ngrids), &
       vlong(nvertx,ngrids), vlat(nvertx,ngrids), &
       farea(nfacex,ngrids), &
       ldist(nedgex,ngrids), ddist(nedgex,ngrids))

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

  ! Constants

  !piby4 = ATAN(1.0d0)
  !pi = 4.0d0*piby4
  piby4=pi/real(4,8)

  !     ---------------------------------------------------------------
  !
  print*, "Basic Calculations"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids
     ! Size of panels on this grid
     n = n0*(2**(igrid-1))
     n2 = n*n
     dlambda = 0.5d0*pi/n

     nface(igrid) = 6*n2
     nedge(igrid) = 2*nface(igrid)
     nvert(igrid) = nface(igrid) + 2

     !
     ! Loop over vertices/faces of one panel
     DO j = 1, n
        lambda2 = (j-1)*dlambda - piby4
        t2 = TAN(lambda2)
        DO i = 1, n
           lambda1 = (i-1)*dlambda - piby4
           t1 = TAN(lambda1)

           !   Set up coordinates of vertices
           !   Panel 1
           !   Index of vertex
           ixv = (j-1)*n + i
           !   Cartesian coordinates of vertex
           x1 = 1.0d0/SQRT(1.0d0 + t1*t1 + t2*t2)
           y1 = x1*t1
           z1 = x1*t2
           !   Lat long coordinates of vertex
           CALL xyz2ll(x1,y1,z1,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Panel 2
           !   Index of vertex
           ixv = ixv + n2
           !   Cartesian coordinates of vertex
           x2 = -y1
           y2 = x1
           z2 = z1
           !   Lat long coordinates of vertex
           CALL xyz2ll(x2,y2,z2,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Panel 3
           !   Index of vertex
           ixv = ixv + n2
           !   Cartesian coordinates of vertex
           x3 = x2
           y3 = -z2
           z3 = y2
           !   Lat long coordinates of vertex
           CALL xyz2ll(x3,y3,z3,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Panel 4
           !   Index of vertex
           ixv = ixv + n2
           !   Cartesian coordinates of vertex
           x4 = -z3
           y4 = y3
           z4 = x3
           !   Lat long coordinates of vertex
           CALL xyz2ll(x4,y4,z4,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Panel 5
           !   Index of vertex
           ixv = ixv + n2
           !   Cartesian coordinates of vertex
           x5 = -y4
           y5 = x4
           z5 = z4
           !   Lat long coordinates of vertex
           CALL xyz2ll(x5,y5,z5,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Panel 6
           !   Index of vertex
           ixv = ixv + n2
           !   Cartesian coordinates of vertex
           x6 = x5
           y6 = -z5
           z6 = y5
           !   Lat long coordinates of vertex
           CALL xyz2ll(x6,y6,z6,long,lat)
           vlong(ixv,igrid) = long
           vlat(ixv,igrid) = lat

           !   Set up incidence tables ignoring complications at
           !   panel edges
           DO p1 = 1, 6
              ixv = (p1 - 1)*n2 + (j-1)*n + i

              !     Edges of the face
              eoff(1,ixv,igrid) = 2*ixv - 1
              eoff(2,ixv,igrid) = 2*ixv
              eoff(3,ixv,igrid) = 2*ixv + 1
              eoff(4,ixv,igrid) = 2*ixv + 2*n
              !     Vertices of the face
              voff(ixv,1,igrid) = ixv
              voff(ixv,2,igrid) = ixv + 1
              voff(ixv,3,igrid) = ixv + n + 1
              voff(ixv,4,igrid) = ixv + n
              !     Faces neighboring this face
              fnxtf(ixv,1,igrid) = ixv - 1
              fnxtf(ixv,2,igrid) = ixv - n
              fnxtf(ixv,3,igrid) = ixv + 1
              fnxtf(ixv,4,igrid) = ixv + n
              !     Edges incident on the vertex
              eofv(1,ixv,igrid) = 2*ixv - 2
              eofv(2,ixv,igrid) = 2*(ixv-n) - 1
              eofv(3,ixv,igrid) = 2*ixv
              eofv(4,ixv,igrid) = 2*ixv - 1

           ENDDO

        ENDDO
     ENDDO

     ! Now sort out complications at panel edges
     DO j = 1, n
        jr = n + 1 - j

        DO pp = 1, 3

           ! Odd numbered panels
           p1 = 2*pp - 1

           ! Left edge of panel p1 joins to top edge of panel p1 - 2
           ! Reverse order
           p2 = MODULO(p1 + 3, 6) + 1
           ixv = (p1 - 1)*n2 + n*(j - 1) + 1
           fnxtf(ixv,1,igrid) = p2*n2 - n + jr
           eofv(1,ixv,igrid) = 2*p2*n2 - 2*n - 1 + 2*(jr + 1)

           ! Bottom edge of panel p1 joins to top edge of panel p1 - 1
           p2 = MODULO(p1 + 4, 6) + 1
           ixv = (p1 - 1)*n2 + j
           fnxtf(ixv,2,igrid) = p2*n2 - n + j
           eofv(2,ixv,igrid) = 2*p2*n2 - 2*n - 1 + 2*j

           ! Right edge of panel p1 joins to left edge of panel p1 + 1
           p2 = MODULO(p1, 6) + 1
           ixv = (p1 - 1)*n2 + n*j
           eoff(3,ixv,igrid) = 2*(p2 - 1)*n2 + 2*(j - 1)*n + 1
           voff(ixv,2,igrid) = (p2 - 1)*n2 + (j - 1)*n + 1
           voff(ixv,3,igrid) = (p2 - 1)*n2 + j*n + 1
           fnxtf(ixv,3,igrid) = (p2 - 1)*n2 + (j - 1)*n + 1

           ! Top edge of panel p1 joins to left edge of panel p1 + 2
           ! Reverse order
           p2 = MODULO(p1 + 1, 6) + 1
           ixv = p1*n2 - n + j
           eoff(4,ixv,igrid) = 2*(p2 - 1)*n2 + 2*(jr - 1)*n + 1
           voff(ixv,3,igrid) = (p2 - 1)*n2 + (jr - 1)*n + 1
           voff(ixv,4,igrid) = (p2 - 1)*n2 + jr*n + 1
           fnxtf(ixv,4,igrid) = (p2 - 1)*n2 + (jr - 1)*n + 1

           ! Even numbered panels
           p1 = 2*pp

           ! Left edge of panel p1 joins to right edge of panel p1 - 1
           p2 = MODULO(p1 + 4, 6) + 1
           ixv = (p1 - 1)*n2 + n*(j - 1) + 1
           fnxtf(ixv,1,igrid) = (p2 - 1)*n2 + n*j
           eofv(1,ixv,igrid) = 2*(p2 - 1)*n2 + 2*n*j

           ! Bottom edge of panel p1 joins to right edge of panel p1 - 2
           ! Reverse order
           p2 = MODULO(p1 + 3, 6) + 1
           ixv = (p1 - 1)*n2 + j
           fnxtf(ixv,2,igrid) = (p2 - 1)*n2 + n*jr
           eofv(2,ixv,igrid) = 2*(p2 - 1)*n2 + 2*n*(jr + 1)

           ! Top edge of panel p1 joins to bottom edge of panel p1 + 1
           p2 = MODULO(p1, 6) + 1
           ixv = p1*n2 - n + j
           eoff(4,ixv,igrid) = 2*(p2 - 1)*n2 + 2*j
           voff(ixv,3,igrid) = (p2 - 1)*n2 + j + 1
           voff(ixv,4,igrid) = (p2 - 1)*n2 + j
           fnxtf(ixv,4,igrid) = (p2 - 1)*n2 + j

           ! Right edge of panel p1 joins to bottom edge of panel p1 + 2
           ! Reverse order
           p2 = MODULO(p1 + 1, 6) + 1
           ixv = (p1-1)*n2 + n*j
           eoff(3,ixv,igrid) = 2*(p2 - 1)*n2 + 2*jr
           voff(ixv,2,igrid) = (p2 - 1)*n2 + jr + 1
           voff(ixv,3,igrid) = (p2 - 1)*n2 + jr
           fnxtf(ixv,3,igrid) = (p2 - 1)*n2 + jr

        ENDDO

     ENDDO

     ! All faces have 4 edges and vertices
     neoff(1:nface(igrid),igrid) = 4

     ! Almost all vertices have 4 edges (exceptions dealt with below)
     neofv(1:nvert(igrid),igrid) = 4

     ! Vertices not correctly captured by the above
     ! Corner vertices only have 3 edges
     DO pp = 1, 3

        ! Bottom left of odd numbered panels
        p1 = 2*pp - 1
        ixv = (p1 - 1)*n2 + 1
        ! First edge needs to be deleted
        eofv(1,ixv,igrid) = eofv(2,ixv,igrid)
        eofv(2,ixv,igrid) = eofv(3,ixv,igrid)
        eofv(3,ixv,igrid) = eofv(4,ixv,igrid)
        eofv(4,ixv,igrid) = 0
        neofv(ixv,igrid) = 3

        ! Bottom left of even numbered panels
        p1 = 2*pp
        ixv = (p1 - 1)*n2 + 1
        ! Second edge needs to be deleted
        eofv(2,ixv,igrid) = eofv(3,ixv,igrid)
        eofv(3,ixv,igrid) = eofv(4,ixv,igrid)
        eofv(4,ixv,igrid) = 0
        neofv(ixv,igrid) = 3

     ENDDO

     ! Vertex 6*n2 + 1 is at top left of panels 1, 3, and 5
     iv = 6*n2 + 1
     lambda2 = piby4
     t2 = TAN(lambda2)
     lambda1 = - piby4
     t1 = TAN(lambda1)
     ! Cartesian coordinates of vertex
     x1 = 1.0d0/SQRT(1.0d0 + t1*t1 + t2*t2)
     y1 = x1*t1
     z1 = x1*t2
     ! Lat long coordinates of vertex
     CALL xyz2ll(x1,y1,z1,long,lat)
     vlong(iv,igrid) = long
     vlat(iv,igrid) = lat
     DO pp = 1, 3
        p1 = 2*pp - 1
        ixv = p1*n2 - n + 1
        voff(ixv,4,igrid) = iv
        eofv(pp,iv,igrid) = 2*p1*n2 - 2*n + 1
     ENDDO
     neofv(iv,igrid) = 3

     ! Vertex 6*n2 + 2 is at bottom right of panels 2, 4, and 6
     iv = 6*n2 + 2
     x1 = -x1
     y1 = -y1
     z1 = -z1
     ! Lat long coordinates of vertex
     CALL xyz2ll(x1,y1,z1,long,lat)
     vlong(iv,igrid) = long
     vlat(iv,igrid) = lat
     DO pp = 1, 3
        p1 = 2*pp
        ixv = (p1 - 1)*n2 + n
        voff(ixv,2,igrid) = iv
        eofv(pp,iv,igrid) = 2*(p1 - 1)*n2 + 2*n
     ENDDO
     neofv(iv,igrid) = 3

  ENDDO ! End of main loop over grids

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

  ! Now construct inverse tables
  ! First initialize entries to zero
  fnxte = 0
  vofe = 0
  fofv = 0

  print*, "Inverse tables"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids

     DO j = 1, nface(igrid)
        DO i = 1, 4
           ie1 = eoff(i,j,igrid)
           CALL addtab2(fnxte(1,1,igrid),ie1,j,2,nedgex)
           ixv = voff(j,i,igrid)
           CALL addtab(fofv(1,1,igrid),ixv,j,nvertx,4)
        ENDDO
     ENDDO

     DO j = 1, nvert(igrid)
        DO i = 1, 4
           ixv = eofv(i,j,igrid)
           IF (ixv > 0) THEN
              CALL addtab2(vofe(1,1,igrid),ixv,j,2,nedgex)
           ENDIF
        ENDDO
     ENDDO

  ENDDO

  ! Calculate geometrical quantities
  print*, "Geometrical quantities"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids
     !DO igrid = 1, ngrids

     ! Smoothing iterations
     DO ismooth = 1, nsmooth

        ! First locate face centres at barycentres of
        ! surrounding vertices
        DO if1 = 1, nface(igrid)
           xc = 0.0d0
           yc = 0.0d0
           zc = 0.0d0
           DO i = 1, 4
              ixv = voff(if1,i,igrid)
              long = vlong(ixv,igrid)
              lat = vlat(ixv,igrid)
              CALL ll2xyz(long,lat,x1,y1,z1)
              xc = xc + x1
              yc = yc + y1
              zc = zc + z1
           ENDDO
           rmag = 1.0d0/SQRT(xc*xc + yc*yc + zc*zc)
           xc = xc*rmag
           yc = yc*rmag
           zc = zc*rmag
           CALL xyz2ll(xc,yc,zc,long,lat)
           flong(if1,igrid) = long
           flat(if1,igrid) = lat
        ENDDO

        ! Next relocate vertices at barycentres of
        ! surrounding face centres - needed for H operator
        DO iv1 = 1, nvert(igrid)
           xc = 0.0d0
           yc = 0.0d0
           zc = 0.0d0
           DO i = 1, neofv(iv1,igrid)
              if1 = fofv(iv1,i,igrid)
              long = flong(if1,igrid)
              lat = flat(if1,igrid)
              CALL ll2xyz(long,lat,x1,y1,z1)
              xc = xc + x1
              yc = yc + y1
              zc = zc + z1
           ENDDO
           rmag = 1.0d0/SQRT(xc*xc + yc*yc + zc*zc)
           xc = xc*rmag
           yc = yc*rmag
           zc = zc*rmag
           CALL xyz2ll(xc,yc,zc,long,lat)
           vlong(iv1,igrid) = long
           vlat(iv1,igrid) = lat
        ENDDO

     ENDDO

     ! Tabulate areas
     DO if1 = 1, nface(igrid)
        long = flong(if1,igrid)
        lat = flat(if1,igrid)
        CALL ll2xyz(long,lat,x0,y0,z0)
        !   Compute face area
        aface = 0.0d0
        DO i = 1, 4
           ie1 = eoff(i,if1,igrid)
           ixv = vofe(1,ie1,igrid)
           long = vlong(ixv,igrid)
           lat = vlat(ixv,igrid)
           CALL ll2xyz(long,lat,x1,y1,z1)
           ixv = vofe(2,ie1,igrid)
           long = vlong(ixv,igrid)
           lat = vlat(ixv,igrid)
           CALL ll2xyz(long,lat,x2,y2,z2)
           CALL starea2(x0,y0,z0,x1,y1,z1,x2,y2,z2,atri)
           aface = aface + atri
        ENDDO
        farea(if1,igrid) = aface
     ENDDO

     ! Tabulate lengths of edges and distances between face centres
     ! across each edge
     lmn=5.0D0
     lmx=0.0D0
     dmn=5.0D0
     dmx=0.0D0
     dav=0.0D0
     DO ie0 = 1, nedge(igrid)
        !   Vertices at ends of this edge
        iv1 = vofe(1,ie0,igrid)
        iv2 = vofe(2,ie0,igrid)
        long = vlong(iv1,igrid)
        lat = vlat(iv1,igrid)
        CALL ll2xyz(long,lat,x1,y1,z1)
        long = vlong(iv2,igrid)
        lat = vlat(iv2,igrid)
        CALL ll2xyz(long,lat,x2,y2,z2)
        CALL spdist(x1,y1,z1,x2,y2,z2,s)
        ldist(ie0,igrid) = s
        lmn = MIN(lmn,ldist(ie0,igrid))
        lmx = MIN(lmx,ldist(ie0,igrid))
        !   Faces either side of this edge
        if1 = fnxte(1,ie0,igrid)
        if2 = fnxte(2,ie0,igrid)
        long = flong(if1,igrid)
        lat = flat(if1,igrid)
        CALL ll2xyz(long,lat,x1,y1,z1)
        long = flong(if2,igrid)
        lat = flat(if2,igrid)
        CALL ll2xyz(long,lat,x2,y2,z2)
        CALL spdist(x1,y1,z1,x2,y2,z2,s)
        ddist(ie0,igrid) = s
        dmn = MIN(dmn,ddist(ie0,igrid))
        dmx = MIN(dmx,ddist(ie0,igrid))
        dav = dav + ddist(ie0,igrid)/nedge(igrid)
     ENDDO

  ENDDO

  ! Sort FNXTF into anticlockwise order on each grid
  ! and sort EOFF to correspond to FNXTF
  ! Also sort fofv into anticlockwise order
  print*, "Sort FNXTF"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids
     !DO igrid = 1, ngrids

     DO if0 = 1, nface(igrid)
        !   Coordinates of face if0
        long = flong(if0,igrid)
        lat = flat(if0,igrid)
        CALL ll2xyz(long,lat,x0,y0,z0)
        DO ix1 = 1, 2
           !     Coordinates of IX1'th neighbour
           if1 = fnxtf(if0,ix1,igrid)
           long = flong(if1,igrid)
           lat = flat(if1,igrid)
           CALL ll2xyz(long,lat,x1,y1,z1)
           d1x = x1 - x0
           d1y = y1 - y0
           d1z = z1 - z0
           !     Find next neighbour (anticlockwise)
           thetamin = pi
           ixmin = 0
           ifmin = 0
           DO ix2 = ix1 + 1, 4
              !       Coordinates of IX2'th neighbour
              if2 = fnxtf(if0,ix2,igrid)
              long = flong(if2,igrid)
              lat = flat(if2,igrid)
              CALL ll2xyz(long,lat,x2,y2,z2)
              d2x=x2 - x0
              d2y=y2 - y0
              d2z=z2 - z0
              cs = d1x*d2x + d1y*d2y + d1z*d2z
              sn = x0*(d1y*d2z - d1z*d2y) &
                   + y0*(d1z*d2x - d1x*d2z) &
                   + z0*(d1x*d2y - d1y*d2x)
              theta = ATAN2(sn,cs)
              IF ((theta < thetamin) .AND. (theta > 0.0d0)) THEN
                 ixmin = ix2
                 ifmin = if2
                 thetamin = theta
              ENDIF
           ENDDO
           !     The face in position IXMIN belongs in position IX1+1 so swap them
           if3 = fnxtf(if0,ix1+1,igrid)
           fnxtf(if0,ix1+1,igrid) = ifmin
           fnxtf(if0,ixmin,igrid) = if3
        ENDDO

        DO ix1 = 1, 4
           if1 = fnxtf(if0,ix1,igrid)
           ix2 = ix1 - 1
           lfound = .FALSE.
           DO WHILE (.NOT. lfound)
              ix2 = ix2 + 1
              ie1 = eoff(ix2,if0,igrid)
              if21 = fnxte(1,ie1,igrid)
              if22 = fnxte(2,ie1,igrid)
              IF ((if21 + if22) == (if0 + if1)) lfound = .TRUE.
           ENDDO
           !     Edge IE2 corresponds to face IF1
           eoff(ix2,if0,igrid) = eoff(ix1,if0,igrid)
           eoff(ix1,if0,igrid) = ie1
        ENDDO

     ENDDO

     DO iv0 = 1, nvert(igrid)
        !   Coordinates of vertex iv0
        long = vlong(iv0,igrid)
        lat = vlat(iv0,igrid)
        CALL ll2xyz(long,lat,x0,y0,z0)
        DO ix1 = 1, neofv(iv0,igrid) - 2
           !     Coordinates of IX1'th face
           if1 = fofv(iv0,ix1,igrid)
           long = flong(if1,igrid)
           lat = flat(if1,igrid)
           CALL ll2xyz(long,lat,x1,y1,z1)
           d1x = x1 - x0
           d1y = y1 - y0
           d1z = z1 - z0
           !     Find next neighbour (anticlockwise)
           thetamin = pi
           ixmin = 0
           ifmin = 0
           DO ix2 = ix1 + 1, neofv(iv0,igrid)
              !       Coordinates of IX2'th neighbour
              if2 = fofv(iv0,ix2,igrid)
              long = flong(if2,igrid)
              lat = flat(if2,igrid)
              CALL ll2xyz(long,lat,x2,y2,z2)
              d2x=x2 - x0
              d2y=y2 - y0
              d2z=z2 - z0
              cs = d1x*d2x + d1y*d2y + d1z*d2z
              sn = x0*(d1y*d2z - d1z*d2y) &
                   + y0*(d1z*d2x - d1x*d2z) &
                   + z0*(d1x*d2y - d1y*d2x)
              theta = ATAN2(sn,cs)
              IF ((theta < thetamin) .AND. (theta > 0.0d0)) THEN
                 ixmin = ix2
                 ifmin = if2
                 thetamin = theta
              ENDIF
           ENDDO
           !     The face in position IXMIN belongs in position IX1+1 so swap them
           if3 = fofv(iv0,ix1+1,igrid)
           fofv(iv0,ix1+1,igrid) = ifmin
           fofv(iv0,ixmin,igrid) = if3
        ENDDO
     ENDDO

  ENDDO

  !
  ! Order VOFF so that the k'th vertex is between the
  ! k'th and (k+1)'th edges in EOFF
  print*, "Sort VOFF"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids
     !DO igrid = 1, ngrids
     DO if0 = 1, nface(igrid)
        DO ix1 = 1, neoff(if0,igrid)
           ix2 = ix1 + 1
           IF (ix2 > neoff(if0,igrid)) ix2 = 1
           ie1 = eoff(ix1,if0,igrid)
           ie2 = eoff(ix2,if0,igrid)
           ! Find the common vertex of IE1 and IE2
           iv11 = vofe(1,ie1,igrid)
           iv12 = vofe(2,ie1,igrid)
           iv21 = vofe(1,ie2,igrid)
           iv22 = vofe(2,ie2,igrid)
           IF ((iv11 == iv21) .OR. (iv11 == iv22)) THEN
              iv0 = iv11
           ELSEIF ((iv12 == iv21) .OR. (iv12 == iv22)) THEN
              iv0 = iv12
           ELSE
              PRINT *,'Common vertex not found'
              STOP
           ENDIF
           voff(if0,ix1,igrid) = iv0
        ENDDO
     ENDDO
  ENDDO

  ! Sort VOFE so that VOFE(1) -> VOFE(2) (tangent vector)
  ! is 90 degrees anticlockwise of FNXTE(1) -> FNXTE(2) (normal vector)
  print*, "Sort VOFE"
  DO igrid = 1, ngrids
     print*, "Grid ", igrid, " of ", ngrids
     !DO igrid = 1, ngrids
     DO ie0 = 1, nedge(igrid)
        if1 = fnxte(1,ie0,igrid)
        if2 = fnxte(2,ie0,igrid)
        long = flong(if1,igrid)
        lat = flat(if1,igrid)
        CALL ll2xyz(long,lat,x0,y0,z0)
        long = flong(if2,igrid)
        lat = flat(if2,igrid)
        CALL ll2xyz(long,lat,x1,y1,z1)
        d1x = x1 - x0
        d1y = y1 - y0
        d1z = z1 - z0
        iv1 = vofe(1,ie0,igrid)
        iv2 = vofe(2,ie0,igrid)
        long = vlong(iv1,igrid)
        lat = vlat(iv1,igrid)
        CALL ll2xyz(long,lat,x0,y0,z0)
        long = vlong(iv2,igrid)
        lat = vlat(iv2,igrid)
        CALL ll2xyz(long,lat,x1,y1,z1)
        d2x = x1 - x0
        d2y = y1 - y0
        d2z = z1 - z0
        sn = x0*(d1y*d2z - d1z*d2y) &
             + y0*(d1z*d2x - d1x*d2z) &
             + z0*(d1x*d2y - d1y*d2x)
        IF (sn < 0.0d0) THEN
           ! Swap the two vertices
           vofe(1,ie0,igrid) = iv2
           vofe(2,ie0,igrid) = iv1
        ENDIF
     ENDDO
  ENDDO

  ! Write out coordinates of edges for plotting
  !OPEN(44,FILE='primalgrid.dat',FORM='FORMATTED')
  !P.Peixoto edit to include grid level in name
  WRITE(ATMP,'(i3.3)') levels
  YNAME="grd/primalgrid_cube_"//trim(ATMP)//".dat"
  print*, "Grid file saved as:", trim(yname)
  OPEN(44,FILE=YNAME,FORM='FORMATTED')
  DO j = 1, nedgex
     iv = vofe(1,j,ngrids)
     long = vlong(iv,ngrids)
     lat = vlat(iv,ngrids)
     CALL ll2xyz(long,lat,x1,y1,z1)
     iv = vofe(2,j,ngrids)
     long = vlong(iv,ngrids)
     lat = vlat(iv,ngrids)
     CALL ll2xyz(long,lat,x2,y2,z2)
     WRITE(44,'(6e15.7)') x1,y1,z1,x2,y2,z2
  ENDDO
  CLOSE(44)

  if (levels <4) then
     !Output for plotting grid in GMT - vertices
     YNAME="grd/cube_"//trim(ATMP)//"_nodes.gmt"
     print*, "Grid file saved as:", trim(yname)
     OPEN(44,FILE=YNAME,FORM='FORMATTED')
     do j=1, nvert(ngrids)
        ! WRITE(22,*) 'Longitudes of vertices - all grids'
        long=vlong(j,ngrids)*rad2deg
        lat=vlat(j,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        !print*, long, lat
        WRITE(44,'(2e15.7)') long, lat
     ENDDO
     CLOSE(44)

     !Write edges for gmt
     YNAME="grd/cube_"//trim(ATMP)//"_ed.gmt"
     print*, "Grid file saved as:", trim(yname)
     OPEN(44,FILE=YNAME)
     write(44, '(a24)') "# Primal Edges (lon, lat)"
     DO j = 1, nedgex
        write(44, '(a8,i10)') "> Edge: ", j
        iv = vofe(1,j,ngrids)
        long = vlong(iv,ngrids)*rad2deg
        lat = vlat(iv,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        write(44,'(2f16.8)') long, lat
        !CALL ll2xyz(long,lat,x1,y1,z1)
        iv = vofe(2,j,ngrids)
        long = vlong(iv,ngrids)*rad2deg
        lat = vlat(iv,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        write(44,'(2f16.8)') long, lat
        !CALL ll2xyz(long,lat,x2,y2,z2)
        !WRITE(44,'(6e15.7)') x1,y1,z1,x2,y2,z2
     ENDDO
     CLOSE(44)

  end if

  !OPEN(44,FILE='dualgrid.dat',FORM='FORMATTED')
  WRITE(ATMP,'(i3.3)') levels
  YNAME="grd/dualgrid_cube_"//trim(ATMP)//".dat"
  print*, "Grid file saved as:", trim(yname)
  OPEN(44,FILE=YNAME,FORM='FORMATTED')
  DO j = 1, nedgex
     if1 = fnxte(1,j,ngrids)
     long = flong(if1,ngrids)
     lat = flat(if1,ngrids)
     CALL ll2xyz(long,lat,x1,y1,z1)
     if1 = fnxte(2,j,ngrids)
     long = flong(if1,ngrids)
     lat = flat(if1,ngrids)
     CALL ll2xyz(long,lat,x2,y2,z2)
     WRITE(44,'(6e15.7)') x1,y1,z1,x2,y2,z2
  ENDDO
  CLOSE(44)

  if (levels <4) then
     !Output for plotting grid in GMT - faces
     YNAME="grd/cube_"//trim(ATMP)//"_trcc.gmt"
     print*, "Grid file saved as:", trim(yname)
     OPEN(44,FILE=YNAME,FORM='FORMATTED')
     do j=1, nface(ngrids)
        ! WRITE(22,*) 'Longitudes of vertices - all grids'
        long = flong(j,ngrids)*rad2deg
        lat = flat(j,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        !print*, long, lat
        WRITE(44,'(2e15.7)') long, lat
     ENDDO
     CLOSE(44)

     !Write edges for gmt
     YNAME="grd/cube_"//trim(ATMP)//"_edhx.gmt"
     print*, "Grid file saved as:", trim(yname)
     OPEN(44,FILE=YNAME)
     write(44, '(a23)') "# Dual Edges (lon, lat)"
     DO j = 1, nedgex
        write(44, '(a8,i10)') "> Edge: ", j
        if1 = fnxte(1,j,ngrids)
     	long = flong(if1,ngrids)*rad2deg
     	lat = flat(if1,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        write(44,'(2f16.8)') long, lat
        !CALL ll2xyz(long,lat,x1,y1,z1)
        if1 = fnxte(2,j,ngrids)
     	long = flong(if1,ngrids)*rad2deg
     	lat = flat(if1,ngrids)*rad2deg
        if(long>180)then
           long=long-360.0
        end if
        write(44,'(2f16.8)') long, lat
        !CALL ll2xyz(long,lat,x2,y2,z2)
        !WRITE(44,'(6e15.7)') x1,y1,z1,x2,y2,z2
     ENDDO
     CLOSE(44)

  end if

  ! Output gridmap file !Edit P. Peixoto grd/
  WRITE(ATMP,'(i10.10)') nfacex
  ygridfile="grd/gridmap_cube_"//trim(ATMP)//".dat"
  !WRITE(ygridfile,'(''grd/gridmap_cube_'',I10.10,''.dat'')') nfacex
  print*, "Grid file saved as:", trim(ygridfile)
  OPEN(22,FILE=ygridfile,FORM='UNFORMATTED')

  ! WRITE(22,*) 'GRIDMAP for NGRIDS=',NGRIDS
  WRITE(22) ngrids
  WRITE(22) nface
  WRITE(22) nedge
  WRITE(22) nvert
  ! WRITE(22,*) 'Number of edges of each face - all grids'
  WRITE(22) ((neoff(if1,igrid),            &
       if1 = 1, nface(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Number of edges of each vertex - all grids'
  WRITE(22) ((neofv(iv1,igrid),            &
       iv1 = 1, nvert(igrid)),   &
       igrid=1, ngrids)
  ! WRITE(22,*) 'Faces next to each face - all grids'
  WRITE(22) (((fnxtf(if1,if2,igrid),       &
       if1 = 1, nface(igrid)),   &
       if2 = 1, 4),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Edges of each face - all grids'
  WRITE(22) (((eoff(ie1,if1,igrid),        &
       ie1 = 1, 4),   &
       if1 = 1, nface(igrid)),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Vertices of each face - all grids'
  WRITE(22) (((voff(if1,iv1,igrid),        &
       if1 = 1, nface(igrid)),   &
       iv1 = 1, 4),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Faces next to each edge - all grids'
  WRITE(22) (((fnxte(if2,ie1,igrid),       &
       if2 = 1, 2),              &
       ie1 = 1, nedge(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Vertices of each edge - all grids'
  WRITE(22) (((vofe(iv2,ie1,igrid),        &
       iv2 = 1, 2),   &
       ie1 = 1, nedge(igrid)),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Faces around each vertex - all grids'
  WRITE(22) (((fofv(iv1,if2,igrid),        &
       iv1 = 1, nvert(igrid)),   &
       if2 = 1, 4),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Edges around each vertex - all grids'
  WRITE(22) (((eofv(ie1,iv1,igrid),        &
       ie1 = 1, 4),   &
       iv1 = 1, nvert(igrid)),              &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Longitudes of faces - all grids'
  WRITE(22) ((flong(if1,igrid),            &
       if1 = 1, nface(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Latitudes of faces - all grids'
  WRITE(22) ((flat(if1,igrid),             &
       if1 = 1, nface(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Longitudes of vertices - all grids'
  WRITE(22) ((vlong(iv1,igrid),            &
       iv1 = 1, nvert(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Latitudes of vertices - all grids'
  WRITE(22) ((vlat(iv1,igrid),             &
       iv1 = 1, nvert(igrid)),   &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Areas of faces - all grids'
  WRITE(22) ((farea(if1,igrid),            &
       if1 = 1, nface(igrid)),    &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Lengths of edges - all grids'
  WRITE(22) ((ldist(ie1,igrid),            &
       ie1 = 1, nedge(igrid)),    &
       igrid = 1, ngrids)
  ! WRITE(22,*) 'Distance between faces across edges - all grids'
  WRITE(22) ((ddist(ie1,igrid),            &
       ie1 = 1, nedge(igrid)),    &
       igrid = 1, ngrids)

  ! WRITE zero value for 'SFC odering not initialized'
  WRITE(22) 0

  !     ---------------------------------------------------------------
  !
END PROGRAM gengrid
!
!     ==================================================================
!
SUBROUTINE LL2XYZ(LONG,LAT,X,Y,Z)
  !
  !     To convert longitude and latitude to cartesian coordinates
  !     on the unit sphere
  !
  IMPLICIT NONE
  !
  REAL*8 LONG,LAT,X,Y,Z,CLN,SLN,CLT,SLT
  !
  !     ------------------------------------------------------------------
  !
  SLN=SIN(LONG)
  CLN=COS(LONG)
  SLT=SIN(LAT)
  CLT=COS(LAT)
  !
  X=CLN*CLT
  Y=SLN*CLT
  Z=SLT
  !
  !     ------------------------------------------------------------------
  !
  RETURN
END SUBROUTINE LL2XYZ
!
!     ==================================================================
!
SUBROUTINE XYZ2LL(X,Y,Z,LONG,LAT)
  !
  !     To convert cartesian coordinates to longitude and latitude
  !
  IMPLICIT NONE
  !
  REAL*8 X,Y,Z,LONG,LAT,PI,TLN,TLT,R
  !
  !     -------------------------------------------------------------------
  !
  PI=4.0D0*ATAN(1.0D0)
  !
  IF (X.EQ.0.0D0) THEN
     IF (Y.GE.0.0D0) THEN
        LONG=0.5D0*PI
     ELSE
        LONG=1.5D0*PI
     ENDIF
  ELSE
     TLN=Y/X
     LONG=ATAN(TLN)
     IF (X.LT.0.0D0) THEN
        LONG=LONG+PI
     ENDIF
     IF (LONG.LT.0.0D0) THEN
        LONG=LONG+2.0D0*PI
     ENDIF
  ENDIF
  !
  R=SQRT(X*X+Y*Y)
  IF (R.EQ.0.0D0) THEN
     IF (Z.GT.0.0D0) THEN
        LAT=0.5D0*PI
     ELSE
        LAT=-0.5D0*PI
     ENDIF
  ELSE
     TLT=Z/R
     LAT=ATAN(TLT)
  ENDIF
  !
  !     --------------------------------------------------------------------
  !
  RETURN
END SUBROUTINE XYZ2LL
!
!     ====================================================================
!
SUBROUTINE ADDTAB(TAB,INDEX,ENTRY,DIM1,DIM2)
  !
  !     Subroutine to add an entry to a table
  !
  INTEGER DIM1,DIM2,TAB(DIM1,DIM2),INDEX,ENTRY
  !
  !     --------------------------------------------------------------------
  !
  I=0
  !
100 CONTINUE
  I=I+1
  IF (I.GT.DIM2) THEN
     PRINT *,'**********'
     PRINT *,'TABLE FULL'
     PRINT *,'**********'
     print *,index,entry,dim1,dim2
     print *,tab(index,:)
     STOP
  ENDIF
  IF (TAB(INDEX,I).NE.0) GOTO 100
  TAB(INDEX,I)=ENTRY
  !
  !     ---------------------------------------------------------------------
  !
  RETURN
END SUBROUTINE ADDTAB

SUBROUTINE addtab2(tab,INDEX,ENTRY,dim1,dim2)

  !     Subroutine to add an entry to a table

  IMPLICIT NONE

  INTEGER, INTENT(IN)                  :: dim1
  INTEGER, INTENT(IN)                  :: dim2
  INTEGER, INTENT(IN OUT)              :: tab(dim1,dim2)
  INTEGER, INTENT(IN OUT)              :: INDEX
  INTEGER, INTENT(IN)                  :: ENTRY

  INTEGER :: i

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

  i=0

100 CONTINUE
  i=i+1
  IF (i > dim1) THEN
     PRINT *,'**********'
     PRINT *,'TABLE FULL'
     PRINT *,'**********'
     STOP
  END IF
  IF (tab(i,INDEX) /= 0) GO TO 100
  tab(i,INDEX)=ENTRY

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

  RETURN
END SUBROUTINE addtab2

!
!     ====================================================================
!
SUBROUTINE STAREA2(X0,Y0,Z0,X1,Y1,Z1,X2,Y2,Z2,AREA)
  !
  !     Calculate the area of the spherical triangle whose corners
  !     have Cartesian coordinates (X0,Y0,Z0), (X1,Y1,Z1), (X2,Y2,Z2)
  !     The formula below is more robust to roundoff error than the
  !     better known sum of angle - PI formula
  !
  IMPLICIT NONE
  !
  REAL*8 X0,Y0,Z0,X1,Y1,Z1,X2,Y2,Z2, &
       D0,D1,D2,S,T0,T1,T2,T3,AREA
  !
  !
  !     Distances between pairs of points
  CALL SPDIST(X0,Y0,Z0,X1,Y1,Z1,D2)
  CALL SPDIST(X1,Y1,Z1,X2,Y2,Z2,D0)
  CALL SPDIST(X2,Y2,Z2,X0,Y0,Z0,D1)
  !
  !     Half perimeter
  S=0.5D0*(D0+D1+D2)
  !
  !     Tangents
  T0 = TAN(0.5D0*(S-D0))
  T1 = TAN(0.5D0*(S-D1))
  T2 = TAN(0.5D0*(S-D2))
  T3 = TAN(0.5D0*S)
  !
  !     Area
  AREA = 4.0D0*ATAN(SQRT(T0*T1*T2*T3))
  !
  RETURN
END SUBROUTINE STAREA2
!
!     ===================================================================
!
SUBROUTINE SPDIST(X1,Y1,Z1,X2,Y2,Z2,S)
  !
  !     Calculate the spherical distance S between two points with Cartesian
  !     coordinates (X1,Y1,Z1), (X2,Y2,Z2) on the unit sphere

  IMPLICIT NONE

  REAL*8 X1, Y1, Z1, X2, Y2, Z2, S, DX, DY, DZ, AD

  DX = X2 - X1
  DY = Y2 - Y1
  DZ = Z2 - Z1
  AD = SQRT(DX*DX + DY*DY + DZ*DZ)
  S = 2.0D0*ASIN(0.5D0*AD)

  RETURN
END SUBROUTINE SPDIST
!
!     ===================================================================


C
C     file hstplr.f
C
      SUBROUTINE HSTPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION ON A STAGGERED
C                        GRID TO THE HELMHOLTZ EQUATION IN POLAR
C                        COORDINATES.  THE EQUATION IS
C
C                           (1/R)(D/DR)(R(DU/DR)) +
C                           (1/R**2)(D/DTHETA)(DU/DTHETA) +
C                           LAMBDA*U = F(R,THETA)
C
C USAGE                  CALL HSTPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,
C                                     IDIMF,PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               A,B
C
C                          THE RANGE OF R, I.E. A .LE. R .LE. B.
C                          A MUST BE LESS THAN B AND A MUST BE
C                          NON-NEGATIVE.
C
C                        M
C                          THE NUMBER OF GRID POINTS IN THE INTERVAL
C                          (A,B).  THE GRID POINTS IN THE R-DIRECTION
C                          ARE GIVEN BY R(I) = A + (I-0.5)DR FOR
C                          I=1,2,...,M WHERE DR =(B-A)/M.
C                          M MUST BE GREATER THAN 2.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT R = A AND R = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT R = A
C                               AND R = B.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT R = A
C                               AND THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT R = B.
C                               (SEE NOTE 1 BELOW)
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE 2 BELOW) AND R = B.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               SPECIFIED AT R = A (SEE NOTE 2 BELOW)
C                               AND THE SOLUTION IS SPECIFIED AT R = B.
C
C
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT R = B.
C
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS SPECIFIED
C                               AT R = B.
C
C                          NOTE 1:
C                          IF A = 0, MBDCND = 2, AND NBDCND = 0 OR 3,
C                          THE SYSTEM OF EQUATIONS TO BE SOLVED IS
C                          SINGULAR.  THE UNIQUE SOLUTION IS
C                          IS DETERMINED BY EXTRAPOLATION TO THE
C                          SPECIFICATION OF U(0,THETA(1)).
C                          BUT IN THIS CASE THE RIGHT SIDE OF THE
C                          SYSTEM WILL BE PERTURBED BY THE CONSTANT
C                          PERTRB.
C
C                          NOTE 2:
C                          IF A = 0, DO NOT USE MBDCND = 3 OR 4,
C                          BUT INSTEAD USE MBDCND = 1,2,5, OR 6.
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES (IF ANY) OF
C                          THE SOLUTION AT R = A.
C
C                          WHEN MBDCND = 1 OR 2,
C                            BDA(J) = U(A,THETA(J)) ,     J=1,2,...,N.
C
C                          WHEN MBDCND = 3 OR 4,
C                            BDA(J) = (D/DR)U(A,THETA(J)) ,
C                            J=1,2,...,N.
C
C                          WHEN MBDCND = 5 OR 6, BDA IS A DUMMY
C                          VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT R = B.
C
C                          WHEN MBDCND = 1,4, OR 5,
C                            BDB(J) = U(B,THETA(J)) ,     J=1,2,...,N.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DR)U(B,THETA(J)) ,
C                            J=1,2,...,N.
C
C                        C,D
C                          THE RANGE OF THETA, I.E. C .LE. THETA .LE. D.
C                          C MUST BE LESS THAN D.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE INTERVAL
C                          (C,D).  THE UNKNOWNS IN THE THETA-
C                          DIRECTION ARE GIVEN BY THETA(J) = C +
C                          (J-0.5)DT,   J=1,2,...,N, WHERE
C                          DT = (D-C)/N.  N MUST BE GREATER THAN 2.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT THETA = C  AND THETA = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN THETA,
C                               I.E. U(I,J) = U(I,N+J).
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = C AND THETA = D
C                               (SEE NOTE BELOW).
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = C AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = D
C                               (SEE NOTE BELOW).
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = C AND THETA = D.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = C AND THE SOLUTION IS
C                               SPECIFIED AT THETA = D
C                               (SEE NOTE BELOW).
C
C                          NOTE:
C                          WHEN NBDCND = 1, 2, OR 4, DO NOT USE
C                          MBDCND = 5 OR 6 (THE FORMER INDICATES THAT
C                          THE SOLUTION IS SPECIFIED AT R =  0; THE
C                          LATTER INDICATES THE SOLUTION IS UNSPECIFIED
C                          AT R = 0).  USE INSTEAD MBDCND = 1 OR 2.
C
C                        BDC
C                          A ONE DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT THETA = C.
C
C                          WHEN NBDCND = 1 OR 2,
C                            BDC(I) = U(R(I),C) ,        I=1,2,...,M.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DTHETA)U(R(I),C),
C                            I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT THETA = D.
C
C                          WHEN NBDCND = 1 OR 4,
C                            BDD(I) = U(R(I),D) ,         I=1,2,...,M.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) =(D/DTHETA)U(R(I),D), I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA IS GREATER THAN 0,
C                          A SOLUTION MAY NOT EXIST.  HOWEVER, HSTPLR
C                          WILL ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT SIDE OF THE HELMHOLTZ
C                          EQUATION.
C
C                          FOR I=1,2,...,M AND J=1,2,...,N
C                            F(I,J) = F(R(I),THETA(J)) .
C
C                          F MUST BE DIMENSIONED AT LEAST M X N.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HSTPLR.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.
C                          IDIMF MUST BE AT LEAST M.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO 13M + 4N +
C                          M*INT(LOG2(N)) LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HSTPLR AND IS RETURNED IN
C                          THE LOCATION W(1).
C
C
C ON OUTPUT
C
C                        F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (R(I),THETA(J)) FOR I=1,2,...,M,
C                          J=1,2,...,N.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC, DERIVATIVE,
C                          OR UNSPECIFIED BOUNDARY CONDITIONS IS
C                          SPECIFIED FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HSTPLR THEN COMPUTES THIS
C                          SOLUTION, WHICH IS A LEAST SQUARES SOLUTION
C                          TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION; HENCE, THE SOLUTION IS NOT
C                          UNIQUE.  THE VALUE OF PERTRB SHOULD BE
C                          SMALL COMPARED TO THE RIGHT SIDE F.
C                          OTHERWISE, A SOLUTION IS OBTAINED TO AN
C                          ESSENTIALLY DIFFERENT PROBLEM.
C                          THIS COMPARISON SHOULD ALWAYS BE MADE TO
C                          INSURE THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS. EXCEPT TO NUMBERS 0 AND 11,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C
C                          =  1  A .LT. 0
C
C                          =  2  A .GE. B
C
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 6
C
C                          =  4  C .GE. D
C
C                          =  5  N .LE. 2
C
C                          =  6  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C                          =  7  A = 0 AND MBDCND = 3 OR 4
C
C                          =  8  A .GT. 0 AND MBDCND .GE. 5
C
C                          =  9  MBDCND .GE. 5 AND NBDCND .NE. 0 OR 3
C
C                          = 10  IDIMF .LT. M
C
C                          = 11  LAMBDA .GT. 0
C
C                          = 12  M .LE. 2
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HSTPLR, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF, GENBUN, GNBNAUX, AND POISTG
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN 1977.
C                        RELEASED ON NCAR'S PUBLIC SOFTWARE LIBRARIES
C                        IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77.
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE-
C                        DIFFERENCE EQUATIONS, INCORPORATES BOUNDARY
C                        DATA, ADJUSTS THE RIGHT SIDE WHEN THE SYSTEM
C                        IS SINGULAR AND CALLS EITHER POISTG OR GENBUN
C                        WHICH SOLVES THE LINEAR SYSTEM OF EQUATIONS.
C
C TIMING                 FOR LARGE M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO M*N*LOG2(N).
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN
C                        A LOSS OF NO MORE THAN FOUR SIGNIFICANT
C                        DIGITS FOR N AND M AS LARGE AS 64.
C                        MORE DETAILED INFORMATION ABOUT ACCURACY
C                        CAN BE FOUND IN THE DOCUMENTATION FOR
C                        ROUTINE POISTG WHICH IS THE ROUTINE THAT
C                        ACTUALLY SOLVES THE FINITE DIFFERENCE
C                        EQUATIONS.
C
C REFERENCES             U. SCHUMANN AND R. SWEET, "A DIRECT METHOD
C                        FOR THE SOLUTION OF POISSON'S EQUATION WITH
C                        NEUMANN BOUNDARY CONDITIONS ON A STAGGERED
C                        GRID OF ARBITRARY SIZE," J. COMP. PHYS.
C                        20(1976), PP. 171-182.
C***********************************************************************
      DIMENSION       F(IDIMF,1)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 10
      IF (M .LE. 2) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/FLOAT(M)
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      MB = MBDCND
      IF (A.EQ.0. .AND. MBDCND.EQ.2) MB = 6
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      DO 101 I=1,M
         J = IWR+I
         W(J) = A+(FLOAT(I)-0.5)*DELTAR
         W(I) = (A+FLOAT(I-1)*DELTAR)/DLRSQ
         K = IWC+I
         W(K) = (A+FLOAT(I)*DELTAR)/DLRSQ
         K = IWB+I
         W(K) = (ELMBDA-2./DLRSQ)*W(J)
  101 CONTINUE
      DO 103 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 102 J=1,N
            F(I,J) = A1*F(I,J)
  102    CONTINUE
  103 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (104,104,106,106,108,108),MB
  104 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 105 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  105 CONTINUE
      GO TO 108
  106 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 107 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  107 CONTINUE
  108 GO TO (109,111,111,109,109,111),MB
  109 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 110 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  110 CONTINUE
      GO TO 113
  111 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 112 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  112 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  113 A1 = 2./DLTHSQ
      GO TO (123,114,114,116,116),NP
  114 DO 115 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  115 CONTINUE
      GO TO 118
  116 A1 = 1./DELTHT
      DO 117 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  117 CONTINUE
  118 A1 = 2./DLTHSQ
      GO TO (123,119,121,121,119),NP
  119 DO 120 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  120 CONTINUE
      GO TO 123
  121 A1 = 1./DELTHT
      DO 122 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  122 CONTINUE
  123 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 133,125,124
  124 IERROR = 11
      GO TO 133
  125 GO TO (133,133,126,133,133,126),MB
  126 GO TO (127,133,133,127,133),NP
  127 CONTINUE
      ISW = 2
      DO 129 J=1,N
         DO 128 I=1,M
            PERTRB = PERTRB+F(I,J)
  128    CONTINUE
  129 CONTINUE
      PERTRB = PERTRB/(FLOAT(M*N)*0.5*(A+B))
      DO 131 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 130 J=1,N
            F(I,J) = F(I,J)-A1
  130    CONTINUE
  131 CONTINUE
      A2 = 0.
      DO 132 J=1,N
         A2 = A2+F(1,J)
  132 CONTINUE
      A2 = A2/W(IWR+1)
  133 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 135 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 134 J=1,N
            F(I,J) = A1*F(I,J)
  134    CONTINUE
  135 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (LP .EQ. 0) GO TO 136
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 137
  136 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  137 CONTINUE
      W(1) = W(IWR+1)+3.*FLOAT(M)
      IF (A.NE.0. .OR. MBDCND.NE.2 .OR. ISW.NE.2) GO TO 141
      A1 = 0.
      DO 138 J=1,N
         A1 = A1+F(1,J)
  138 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
      DO 140 I=1,M
         DO 139 J=1,N
            F(I,J) = F(I,J)+A1
  139    CONTINUE
  140 CONTINUE
  141 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


!===============================================================================
program test_spherical_splines
!===============================================================================
!  Create an array of knots, supply some function, then re-express that using
!  the spherical_splines module

   use spherical_splines
   use spherical_geometry, only: sphere_sample

   real(8),parameter :: pi = atan2(1._8,1._8)*4._8

   real(8) :: dd=4. ! approx distance between knot points
   real(8) :: sigma=0.2
   real(8),allocatable,dimension(:) :: lon,lat
   integer :: n  ! number of points
   real(8),dimension(1) :: val,vlon,vcolat
   type(sph_splines_set) :: s

!  Create the knot points
   call sphere_sample(dd,lon,lat,n)

!  Create the knot points on a regular lon,lat grid
!   n = 360*(180-int(dd))/int(dd**2) + 1
!   allocate(lon(n), lat(n))
!   lon(1) = 0.  ;  lat(1) = 90.
!   vlon(1) = -180.
!   do while(vlon(1) < 180.)
!      vcolat(1) = 90. - dd
!      do while (vcolat(1) > -90.)
!         i = i + 1
!         lon(i) = vlon(1)
!         lat(i) = vcolat(1)
!         vcolat(1) = vcolat(1) - dd
!      enddo
!      vlon(1) = vlon(1) + dd
!   enddo
!   i = i + 1
!   lon(i) = 0.  ;  lat(i) = -90.
!
!   if (i /= n) then
!      write(0,'(2(a,i0))') 'i /= n !!    i = ',i,' /= n = ',n
!      stop
!   endif

!  Make room for the values at each knot
   allocate(s%phi(n),s%theta(n),s%a(n),s%c(n))
   s%phi = lon
   s%theta = 90._8 - lat
   s%n = n

!  Fill the points with a bulge at the equator, width controlled by sigma
   s%c = exp((-(s%phi*pi/180._8)**2 - (pi/2._8 - (s%theta*pi/180._8))**2)/sigma**2)
   s%degrees = .true.

!  Alternatively, create a checkerboard
!   s%c = sign(1._8,cos(2._8*s%phi*pi/180._8)*cos(2._8*s%theta*pi/180._8))

!  Make the shape sharp sided
   where (s%c > 0.5)
      s%c = 1.
   elsewhere
      s%c = 0.
   endwhere

!  Choose a desired kernel and scaling for the Abel-Poisson
!   s%kernel = 'AP'
!   dd = 10.
!   s%h = sph_splines_AP_width2h(dd,degrees=.true.)

!  Fit the splines to the data
   call sph_splines_fit_AP(s,half_width=dd)
!   write(*,*) s%a

!  Write out points on a regular lon,lat grid
outer:   do j=45,135,3
      do i=-50,50,3
         vlon(1) = real(i)
         vcolat(1) = real(j)
         call sph_splines_eval(vlon,vcolat,s,val,degrees=.true.)
         write(*,*) i,90-j,val(1)
      enddo
   enddo outer

!  Write out knot locations

end program


      PROGRAM xsvbksb
C     driver for routine svbksb, which calls routine svdcmp
      INTEGER MP,NP
      PARAMETER(MP=20,NP=20)
      INTEGER j,k,l,m,n
      REAL a(NP,NP),b(NP,MP),u(NP,NP),w(NP)
      REAL v(NP,NP),c(NP),x(NP)
      REAL wmax,wmin
      CHARACTER dummy*3
      open(7,file='MATRX1.DAT',status='old')
10    read(7,'(a)') dummy
      if (dummy.eq.'END') goto 99
      read(7,*)
      read(7,*) n,m
      read(7,*)
      read(7,*) ((a(k,l), l=1,n), k=1,n)
      read(7,*)
      read(7,*) ((b(k,l), k=1,n), l=1,m)
C     copy a into u
      do 12 k=1,n
        do 11 l=1,n
          u(k,l)=a(k,l)
11      continue
12    continue
C     decompose matrix a
      call svdcmp(u,n,n,NP,NP,w,v)
C     find maximum singular value
      wmax=0.0
      do 13 k=1,n
        if (w(k).gt.wmax) wmax=w(k)
13    continue
C     define "small"
      wmin=wmax*(1.0e-6)
C     zero the "small" singular values
      do 14 k=1,n
        if (w(k).lt.wmin) w(k)=0.0
14    continue
C     backsubstitute for each right-hand side vector
      do 18 l=1,m
        write(*,'(1x,a,i2)') 'Vector number ',l
        do 15 k=1,n
          c(k)=b(k,l)
15      continue
        call svbksb(u,w,v,n,n,NP,NP,c,x)
        write(*,*) '    Solution vector is:'
        write(*,'(1x,6f12.6)') (x(k), k=1,n)
        write(*,*) '    Original right-hand side vector:'
        write(*,'(1x,6f12.6)') (c(k), k=1,n)
        write(*,*) '    Result of (matrix)*(sol''n vector):'
        do 17 k=1,n
          c(k)=0.0
          do 16 j=1,n
            c(k)=c(k)+a(k,j)*x(j)
16        continue
17      continue
        write(*,'(1x,6f12.6)') (c(k), k=1,n)
18    continue
      write(*,*) '***********************************'
      write(*,*) 'Press RETURN for next problem'
      read(*,*)
      goto 10
99    close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsvbksb.for


!##############################################################################
! PROGRAM mortality_riskmanagement
!
! ## Mortality risk management with Monte Carlo simulations
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog04_09m.f90"

program mortality_riskmanagement

    use toolbox
    use globals

    implicit none

    ! initialize mortality data
    call init_data

    !########################################################
    ! SIMULATE DIFFERENT MORTAILITY TABLES
    !########################################################

    ! MC simulations of mortality tables
    do ik = 1, KK

        ! simulate innovations to the random walk
        call simulate_normal(eps, 0d0, sigma_eps)

        ! calculate common risk-factor
        kappa(0) = 0d0
        do it = 1, TT
            kappa(it) = kappa(it-1) + c + eps(it)
        enddo

        ! determine conditional mortality rates (Lee-Carter model)
        do it = 0, TT
            q(:, it, ik) = exp(alpha + beta*kappa(it))
        enddo
    enddo

    ! store current probabilities in entry zero
    do it = 1, TT
        q(:, it, 0) = q(:, 0, 0)
    enddo

    ! calculate unconditional survival probabilities and life expectancy
    do ik = 0, KK
        do ix = 1, XX
            LE(ix, ik) = 0d0
            PP(ix, 0, ik) = 1d0
            do it = 1, XX - ix
                PP(ix, it, ik) = PP(ix, it-1, ik)*(1d0 - q(ix+it-1, it-1, ik))
                LE(ix, ik) = LE(ix, ik) + PP(ix, it, ik)*q(ix+it, it, ik)*dble(it)
            enddo
        enddo
    enddo

    ! determine path with highest and lowest life expectancy (at age 20-24)
    ik_min = minloc(LE(1, 1:KK), 1)
    ik_max = maxloc(LE(1, 1:KK), 1)

    ! determine plotting data
    do it = 0, TT
        age(it) = 20d0 + 5d0*dble(it)
        PP_av(it)  = sum(PP(1, it, 1:KK))/dble(KK)
        PP_min(it) = PP(1, it, ik_min)
        PP_max(it) = PP(1, it, ik_max)
    enddo
    age(TT+1)    = 100d0
    PP_av(TT+1)  = 0d0
    PP_min(TT+1) = 0d0
    PP_max(TT+1) = 0d0

    ! create plot of unconditional survival probabilities
    call plot(age, PP_av, color='blue', legend='Average')
    call plot(age, PP_min, color='blue', legend='Minimum', marker=6, noline=.true.)
    call plot(age, PP_max, color='blue', legend='Maximum', marker=4, noline=.true.)
    call execplot(xlabel='Age x', ylabel='Uncond. Survival Probability')

    ! print results
    write(*,*)
    write(*,'(a/)')'ESTIMATES FOR LIFE EXPECTANCY AT AGE 20'
    write(*,'(a,f10.3)')'Average = ', 20d0 + 5d0*sum(LE(1, :))/dble(KK)
    write(*,'(a,f10.3)')'Minimum = ', 20d0 + 5d0*LE(1, ik_min)
    write(*,'(a,f10.3)')'Maximum = ', 20d0 + 5d0*LE(1, ik_max)
    write(*,*)

    !########################################################
    ! CALCULATE PREMIA OF INSURANCE POLICIES
    !########################################################

    ! premium calculation for different insurance polices
    do ii = 1, NN
        ix = ins(ii)%ix
        im = ins(ii)%im
        id = ins(ii)%id

        if(ins(ii)%itype == 'AI')then
            p_m(ii) = AI(ix, im, id, 0)*(1d0 + xi_1)
        else
            p_m(ii) = LI(ix, im, id, 0)*(1d0 - xi_2)
        endif
    enddo

    ! get the total sum of premia payed for insuance contracts
    sum_premia = sum(ins(:)%n_ins*p_m*ins(:)%BB)

    ! determine shares in the insurer's portfolio
    omega = ins(:)%n_ins*p_m*ins(:)%BB/sum_premia

    ! print results
    write(*,'(/a/)')'PORTFOLIO OF THE INSURER'
    write(*,'(a)')'  #       x   m   d  Benefits     Price    Weight'
    do ii = 1, NN
        write(*, '(i3,a4,3i4,f10.1,2f10.3)')ii, ins(ii)%itype, &
                ins(ii)%ix, ins(ii)%im, ins(ii)%id, ins(ii)%BB, p_m(ii), omega(ii)*100d0
    enddo
    write(*, '(/a,f12.1/)')'Sum of premia payed (in million Euro)', &
        sum_premia/1000000d0

    !########################################################
    ! SIMULATE BENEFIT-PREMIUM RATIOS
    !########################################################

    ! calculate benefit-premium ratios for all simulations
    do ii = 1, NN
        ix = ins(ii)%ix
        im = ins(ii)%im
        id = ins(ii)%id

        if(ins(ii)%itype == 'AI')then
            do ik = 1, KK
                l(ii, ik) = AI(ix, im, id, ik)/p_m(ii)
            enddo
        else
            do ik = 1, KK
                l(ii, ik) = LI(ix, im, id, ik)/p_m(ii)
            enddo
        endif
    enddo

    ! sum up portfolio weighted benefit-premium ratios
    do ik = 1, KK
        l_p(ik) = sum(omega*l(1:NN, ik))
    enddo

    ! determine mean of benefit-premium ratios
    do ii = 1, NN
        mu(ii) = sum(l(ii,:))/dble(KK)
    enddo
    mu_p = sum(omega*mu)

    ! compute variance-covariance matrix of benefit-premium ratios
    sig_p = 0d0
    do ii = 1, NN
        do ij = 1, NN
            sig(ii, ij) = sum((l(ii,:)-mu(ii))*(l(ij,:)-mu(ij)))/dble(KK-1)
            sig_p = sig_p + sig(ii,ij)*omega(ii)*omega(ij)
        enddo
    enddo

    ! compute VaR and CVaR for portfolio
    call sort(l_p)
    ii_VaR = ceiling(0.95d0*KK)
    VaR    = l_p(ii_VaR)
    CVaR   = sum(l_p(ii_VaR:KK))/dble(KK-ii_VaR+1)

    ! print results
    write(*,'(/a/)')'PORTFOLIO CHARACTERISTICS'
    write(*,'(a, 5f10.3/)')'mu    = ', mu
    write(*,'(a, 5f10.3)')'sig   = ', sig(ii, :)
    do ii = 2, NN
        write(*,'(8x,5f10.3)')sig(ii, :)
    enddo
    write(*,'(/2(a,f10.3,4x))')'mu_p  = ', mu_p, 'sig_p = ', sig_p
    write(*,'(2(a,f10.3,4x)/)')'VaR   = ',  VaR, 'CVaR  = ',  CVar

    !########################################################
    ! COMPUTE OPTIMAL PORTFOLIO
    !########################################################

    ! initial guess for portfolio shares
    x_in(1:NN) = 1d0/dble(NN)

    ! initial guess for multipliers
    x_in(NN+1:2*NN+1) = 0d0

    ! solve first oder conditions
    call fzero(x_in, focs, check)

    ! check for convergence
    if(check) stop 'Error: fzero did not converge'

    ! copy decision
    omega   = x_in(1:NN)

    !########################################################
    ! GET PROPERTIES OF OPTIMAL PORTFOLIO
    !########################################################

    ! calculate new portfolio mean, variance and VaR's
    mu_p  = sum(omega*mu)
    sig_p = dot_product(matmul(omega, sig), omega)
    n_new = omega*sum_premia/(p_m*ins(:)%BB)

    ! sum up portfolio weighted benefit-premium ratios
    do ik = 1, KK
        l_p(ik) = sum(omega*l(1:NN, ik))
    enddo

    ! compute VaR and CVaR for portfolio
    call sort(l_p)
    ii_VaR = ceiling(0.95d0*KK)
    VaR    = l_p(ii_VaR)
    CVaR   = sum(l_p(ii_VaR:KK))/dble(KK-ii_VaR+1)

    ! print results
    write(*,'(/a/)')'OPTIMAL PORTFOLIO'
    write(*,'(a, 5f10.3)')'omega = ', omega
    write(*,'(a, 5f10.3)')'n     = ', n_new
    write(*,'(/2(a,f10.3,4x))')'mu_p  = ', mu_p, 'sig_p = ', sig_p
    write(*,'(2(a,f10.3,4x)/)')'VaR   = ',  VaR, 'CVaR  = ',  CVar

contains

    ! expected present value of annuity insurance benefits
    function AI(ix, im, id, ik)

        implicit none
        integer, intent(in) :: ix, im, id, ik
        real*8 :: AI
        integer :: it

        AI = 0d0
        do it = im, im+id-1
            AI = AI + PP(ix, it, ik)/(1+r)**it
        enddo

    end function AI

    ! expected present value of life insurance benefits
    function LI(ix, im, id, ik)

        implicit none
        integer, intent(in) :: ix, im, id, ik
        real*8 :: LI
        integer :: it

        LI = 0d0
        do it = im, im+id-1
            LI = LI + PP(ix, it, ik)*q(ix+it, it, ik)/(1+r)**(it+1)
        enddo

    end function LI

    ! initialize mortality and portfolio data
    subroutine init_data()

        implicit none

        q = 0d0

        ! mortality probabilities in the base period (t = 0)
        q(1,  0, :) = 0.00186d0
        q(2,  0, :) = 0.00222d0
        q(3,  0, :) = 0.00268d0
        q(4,  0, :) = 0.00389d0
        q(5,  0, :) = 0.00632d0
        q(6,  0, :) = 0.01123d0
        q(7,  0, :) = 0.01957d0
        q(8,  0, :) = 0.02987d0
        q(9,  0, :) = 0.04483d0
        q(10, 0, :) = 0.06528d0
        q(11, 0, :) = 0.10007d0
        q(12, 0, :) = 0.17166d0
        q(13, 0, :) = 0.28709d0
        q(14, 0, :) = 0.46296d0
        q(15, 0, :) = 0.66523d0
        q(16, :, :) = 1.00000d0

        ! parameters of the Lee-Carter Model !!! Here 0.02 in first entry
        alpha = log(q(:, 0, 1))
        beta  = (/ 0.02d0, 0.12d0, 0.12d0, 0.11d0, 0.10d0, 0.08d0, 0.07d0, 0.06d0, &
                   0.05d0, 0.05d0, 0.05d0, 0.05d0, 0.05d0, 0.04d0, 0.03d0, 0.00d0 /)

        ! define different insurance types
        ins(1) = insurance_type('AI', 9, 1, 7,  50000d0, 1000d0)
        ins(2) = insurance_type('AI',10, 0, 7,  50000d0, 1000d0)
        ins(3) = insurance_type('LI', 6, 0, 7, 500000d0, 1000d0)
        ins(4) = insurance_type('LI', 8, 0, 7, 500000d0, 1000d0)
        ins(5) = insurance_type('LI', 8, 0, 9, 500000d0, 1000d0)

    end subroutine init_data

end program


program main

!*****************************************************************************80
!
!! MAIN is the main program for MANDELBROT_OPENMP.
!
!  Discussion:
!
!    MANDELBROT_OPENMP computes an image of the Mandelbrot set.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 July 2010
!
!  Author:
!
!    John Burkardt
!
!  Local Parameters:
!
!    Local, integer COUNT_MAX, the maximum number of iterations taken
!    for a particular pixel.
!
  use omp_lib

  implicit none

  integer ( kind = 4 ), parameter :: m = 500
  integer ( kind = 4 ), parameter :: n = 500

  integer ( kind = 4 ) b(m,n)
  integer ( kind = 4 ) c
  integer ( kind = 4 ) c_max
  integer ( kind = 4 ) count(m,n)
  integer ( kind = 4 ) :: count_max = 2000
  integer ( kind = 4 ) g(m,n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) ios
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  integer ( kind = 4 ) k
  character ( len = 255 ) output_filename
  integer ( kind = 4 ) output_unit
  integer ( kind = 4 ) r(m,n)
  real ( kind = 8 ) wtime
  real ( kind = 8 ) wtime_total
  real ( kind = 8 ) :: x_max =   1.25D+00
  real ( kind = 8 ) :: x_min = - 2.25D+00
  real ( kind = 8 ) x
  real ( kind = 8 ) x1
  real ( kind = 8 ) x2
  real ( kind = 8 ) :: y_max =   1.75D+00
  real ( kind = 8 ) :: y_min = - 1.75D+00
  real ( kind = 8 ) y
  real ( kind = 8 ) y1
  real ( kind = 8 ) y2

  call timestamp ( )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MANDELBROT_OPENMP'
  write ( *, '(a)' ) '  FORTRAN90/OpenMP version'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Create an ASCII PPM image of the Mandelbrot set.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  For each point C = X + i*Y'
  write ( *, '(a,g14.6,a,g14.6,a)' ) '  with X range [', x_min, ',', x_max, ']'
  write ( *, '(a,g14.6,a,g14.6,a)' ) '  and  Y range [', y_min, ',', y_max, ']'
  write ( *, '(a,i8,a)' ) '  carry out ', count_max, ' iterations of the map'
  write ( *, '(a)' ) '  Z(n+1) = Z(n)^2 + C.'
  write ( *, '(a)' ) '  If the iterates stay bounded (norm less than 2)'
  write ( *, '(a)' ) '  then C is taken to be a member of the set.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  An ASCII PPM image of the set is created using'
  write ( *, '(a,i8,a)' ) '    M = ', m, ' pixels in the X direction and'
  write ( *, '(a,i8,a)' ) '    N = ', n, ' pixels in the Y direction.'

  wtime = omp_get_wtime ( )
!
!  Carry out the iteration for each pixel, determining COUNT.
!
!$omp parallel &
!$omp shared ( b, count, count_max, g, r, x_max, x_min, y_max, y_min ) &
!$omp private ( i, j, k, x, x1, x2, y, y1, y2 )

!$omp do

  do i = 1, m

    do j = 1, n

      x = ( real (     j - 1, kind = 8 ) * x_max   &
          + real ( m - j,     kind = 8 ) * x_min ) &
          / real ( m     - 1, kind = 8 )

      y = ( real (     i - 1, kind = 8 ) * y_max   &
          + real ( n - i,     kind = 8 ) * y_min ) &
          / real ( n     - 1, kind = 8 )

      count(i,j) = 0

      x1 = x
      y1 = y

      do k = 1, count_max

        x2 = x1 * x1 - y1 * y1 + x
        y2 = 2 * x1 * y1 + y

        if ( x2 < -2.0D+00 .or. 2.0D+00 < x2 .or. &
             y2 < -2.0D+00 .or. 2.0D+00 < y2 ) then
          count(i,j) = k
          exit
        end if

        x1 = x2
        y1 = y2

      end do

      if ( mod ( count(i,j), 2 ) == 1 ) then
        r(i,j) = 255
        g(i,j) = 255
        b(i,j) = 255
      else
        c = int ( 255.0D+00 * sqrt ( sqrt ( sqrt ( &
          ( real ( count(i,j), kind = 8 ) &
          / real ( count_max, kind = 8 ) ) ) ) ) )
        r(i,j) = 3 * c / 5
        g(i,j) = 3 * c / 5
        b(i,j) = c
      end if

    end do

  end do
!$omp end do

!$omp end parallel

  wtime = omp_get_wtime ( ) - wtime
  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  Time = ', wtime
!
!  Write data to an ASCII PPM file.
!
  output_unit = 10
  output_filename = 'mandelbrot_openmp.ppm'

  open ( unit = output_unit, file = output_filename, status = 'replace', &
    form = 'formatted', access = 'sequential', iostat = ios )

  write ( output_unit, '(a2)' ) 'P3'
  write ( output_unit, '(i5,2x,i5)' ) n, m
  write ( output_unit, '(i3)' ) 255
  do i = 1, m
    do jlo = 1, n, 4
      jhi = min ( jlo + 3, n )
      write ( output_unit, '(12i5)' ) &
        ( r(i,j), g(i,j), b(i,j), j = jlo, jhi )
    end do
  end do

  close ( unit = output_unit )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '  Graphics data written to "' // trim ( output_filename ) // '".'
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MANDELBROT_OPENMP'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


program jacobimpi
! JACOBIMPI - Solves the Poisson equation using Jacobi. Uses mpi.
!
! PUBLIC ROUTINES DEFINED
!   · isNotPerfectSquare  - returns true if the argument is not a perfect square
!   · InfNorm             - returnts the infinity norm of a 2D array
!   · rhs                 - returns the RHS of the Poisson equation
!   · uexact              - returns the exact solution to the problem
!
! REQUIRED DEPENDENCIES
!   · precision - to define KINDs for single and double floating-point
!   · mpi
!
! REVISION HISTORY
!   11/23/2018 - Serial implementation
!   11/25/2018 - Parallel implementation using mpi for only one processor
!   12/02/2018 - Fixed communications, works for multiple processors
!
! PROGRAMMER
! Francisco Castillo

    use, intrinsic::iso_fortran_env
    use mpi
    use precision

    implicit none
    integer, parameter :: ROOT=0, INTERNAL_ERROR=1
    integer  :: me, npes, beta, k, k1, k2
    integer  :: M, N, i, j, iter, ierr, nargs, auxM, auxN
    real(DP) :: xMin, xMax, yMin, yMax, hx, hy
    real(DP) :: delta, deltaALL, c, bcleft, bcright, bcup, bcdown
    real(DP), dimension(:),   allocatable :: x, y
    real(DP), dimension(:,:), allocatable :: f, sol, u, uold, ucomp
    real(DP), dimension(:,:), allocatable :: metest

    real(DP) :: xyextent(4), BCsData(4), deltaConv
    integer  :: gridData(2), iterMax, q, Mme, Nme
    integer  :: status(MPI_STATUS_SIZE)
    character(20)  :: filename='jacobi.txt'
    character(200) :: errmsg='none'
    namelist/jacobiparams/ xyextent, gridData, iterMax, q, deltaConv, BCsData

    call mpi_init(ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
    call mpi_comm_size(MPI_COMM_WORLD, npes, ierr)

    ! Check that we can create a nxn division of the grid using n^2 processing
    ! elements. We need a perfect square.
    if(isNotPerfectSquare(npes)) goto 912

    ! This portion of the code reads the data from the file jacobi.txt, if there
    ! is any error, it continues after the tag 911 to exit with an error
    if(me.eq.ROOT) then
      nargs = command_argument_count()
      if(nargs.gt.0) call get_command_argument(1,filename)
      open(unit=4, file=filename, status='old', iostat=ierr, iomsg=errmsg)
      if(ierr.ne.0) goto 911
      read(4,jacobiparams,iostat=ierr,iomsg=errmsg)
      if(ierr.ne.0) goto 911
      close(4,iostat=ierr, iomsg=errmsg)
      if(ierr.ne.0) goto 911
    endif
    ! Broadcast the needed data, to all processing elements
    call mpi_bcast(xyextent,4, MPI_DOUBLE, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(gridData,2, MPI_INTEGER, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(iterMax,1, MPI_INTEGER, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(q,1, MPI_INTEGER, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(deltaConv,1, MPI_DOUBLE, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(BCsData,4, MPI_DOUBLE, ROOT, MPI_COMM_WORLD, ierr)

    xMin = xyextent(1)
    xMax = xyextent(2)
    yMin = xyextent(3)
    yMax = xyextent(4)
    M = gridData(1)
    N = gridData(2)
    bcleft  = BCsData(1)
    bcright = BCsData(2)
    bcup    = BCsData(3)
    bcdown  = BCsData(4)
    ! The root process prints a summary of the parameters
    if(me.eq.ROOT) then
      print*, " "
      print*, "--------------------------------------"
      print*, "|------------ PARAMETERS ------------|"
      print*, "--------------------------------------"
      print*, "| Number of processes : ", npes
      print*, "| Process number : ", me
      print*, "--------------------------------------"
      print*, "| xMin = ", xMin
      print*, "| xMax = ", xMax
      print*, "| yMin = ", yMin
      print*, "| yMax = ", yMax
      print*, "| M = ", M
      print*, "| N = ", N
      print*, "| iterMax = ", iterMax
      print*, "| q = ", q
      print*, "| deltaConv = ", deltaConv
      print*, "| BCleft  = ", bcleft
      print*, "| BCright = ", bcright
      print*, "| BCup    = ", bcup
      print*, "| BCdown  = ", bcdown
      print*, "--------------------------------------"
    endif

    hx = (xMax-xMin)/M
    hy = (yMax-yMin)/N
    ! Define the parameters needed to organize the subdomains
    ! I call subdomain the portion of the grid assign to each processing element
    beta = sqrt(DBLE(npes))
    auxM = (M+1)/beta
    auxN = (N+1)/beta
    k1 = MOD(me,beta)         ! Organizes the subdomaing from left to right
    k2 = FLOOR(DBLE(me/beta)) ! Organizes the subdomaing from bottom to top

    ! Create the local grid
    if (k1.eq.0) then ! Left subdomains
      allocate(x(0:auxM))
      x = [(hx*(j-1)+xMin, j=1, auxM+1)]
    elseif (k1.eq.beta-1) then ! Right subdomains
      allocate(x(0:auxM))
      x = [(hx*(j-1)+xMin, j=auxM*k1, auxM*(k1+1))]
    else
      allocate(x(0:auxM+1)) ! The inner subdomains have one x-dimension higher than the extremes
      x = [(hx*(j-1)+xMin, j=auxM*k1, auxM*(k1+1)+1)]
    endif

    if (k2.eq.0) then ! Bottom subdomains
      allocate(y(0:auxN))
      y = [(hy*(j-1)+yMin, j=1, auxN+1)]
    elseif (k2.eq.beta-1) then ! Top subdomains
      allocate(y(0:auxN))
      y = [(hy*(j-1)+yMin, j=auxN*k2, auxN*(k2+1))]
    else
      allocate(y(0:auxN+1)) ! The inner subdomains have one y-dimension higher than the extremes
      y = [(hy*(j-1)+yMin, j=auxN*k2, auxN*(k2+1)+1)]
    endif

    ! Save the size of the assigned subdomain
    Mme = size(x)-1
    Nme = size(y)-1

    allocate(f(0:Mme,0:Nme))      ! RHS
    allocate(sol(0:Mme,0:Nme))    ! Exact solution
    allocate(u(0:Mme,0:Nme))      ! Updated solution u
    allocate(uold(0:Mme,0:Nme))   ! Old suludion uold
    allocate(ucomp(0:Mme,0:Nme))  ! Saved comparison solution ucomp

    f   = rhs(x,y,Mme,Nme)
    sol = uexact(x,y,Mme,Nme)

    ! Initialization of u and Boundary Conditions
    u = 0d0  ! Initialization of u
    if (k1.eq.0)        u(0,:)   = bcleft
    if (k1.eq.(beta-1)) u(Mme,:) = bcright
    if (k2.eq.0)        u(:,0)   = bcdown
    if (k2.eq.(beta-1)) u(:,Nme) = bcup

    uold  = u
    ucomp = u

    do iter=1,iterMax
      do i=1,Mme-1
        do j=1,Nme-1
          ! Jacobi iteration for different hx and hy
          u(i,j) = (hy**2d0*(uold(i-1,j)+uold(i+1,j))+&
                    hx**2d0*(uold(i,j-1)+uold(i,j+1))-&
                    hx**2d0*hy**2d0*f(i,j))/(2*(hx**2d0+hy**2d0))
        enddo
      enddo
      ! Communication between processing units, updates ghost cells
      if (MOD(me,2)==1) then
        call MPI_Sendrecv(u(1,1:Nme-1),Nme-1,MPI_DOUBLE,me-1,90,&
            u(0,1:Nme-1),Nme-1,MPI_DOUBLE,me-1,91,MPI_COMM_WORLD,status,ierr)
        if(MOD((me+1),beta).ne.0) call MPI_Sendrecv(u(Mme-1,1:Nme-1),Nme-1,&
                MPI_DOUBLE,me+1,92,u(Mme,1:Nme-1),Nme-1,MPI_DOUBLE,me+1,93,&
                                                      MPI_COMM_WORLD,status,ierr)
      else
        call MPI_Sendrecv(u(Mme-1,1:Nme-1),Nme-1,MPI_DOUBLE,me+1,91,&
            u(Mme,1:Nme-1),Nme-1,MPI_DOUBLE,me+1,90,MPI_COMM_WORLD,status,ierr)
        if(MOD(me,beta).ne.0) call MPI_Sendrecv(u(1,1:Nme-1),Nme-1,MPI_DOUBLE,&
                me-1,93,u(0,1:Nme-1),Nme-1,MPI_DOUBLE,me-1,92,MPI_COMM_WORLD,&
                                                                      status,ierr)
      endif

      if (MOD(k2,2)==1) then
        call MPI_Sendrecv(u(1:Mme-1,1),Mme-1,MPI_DOUBLE,me-beta,94,&
            u(1:Mme-1,0),Mme-1,MPI_DOUBLE,me-beta,95,MPI_COMM_WORLD,status,ierr)
        if(k2+1.lt.beta) call MPI_Sendrecv(u(1:Mme-1,Nme-1),Mme-1,MPI_DOUBLE,&
                      me+beta,96,u(1:Mme-1,Nme),Mme-1,MPI_DOUBLE,me+beta,97,&
                                                      MPI_COMM_WORLD,status,ierr)
      else
        call MPI_Sendrecv(u(1:Mme-1,Nme-1),Mme-1,MPI_DOUBLE,me+beta,95,&
                  u(1:Mme-1,Nme),Mme-1,MPI_DOUBLE,me+beta,94,MPI_COMM_WORLD,&
                                                                      status,ierr)
        if(k2.ne.0) call MPI_Sendrecv(u(1:Mme-1,1),Mme-1,MPI_DOUBLE,me-beta,97,&
                  u(1:Mme-1,0),Mme-1,MPI_DOUBLE,me-beta,96,MPI_COMM_WORLD,&
                                                                    status,ierr)
      endif
      ! Update the value of uold for the next iteration
      uold = u
      ! Every q iterations check for convergence
      ! Use MPI_ALLreduce because I need the maximum of deltas stored in all the
      ! processing units so all of them can exit or not.
      if (MOD(iter,q)==0) then
        k=iter
        delta = InfNorm(u-ucomp)
        call MPI_ALLreduce(delta,deltaALL,1,MPI_DOUBLE,MPI_MAX,MPI_COMM_WORLD,ierr)
        if(deltaALL.lt.deltaConv) exit
        if(iter.lt.iterMax) ucomp = u
      endif
    enddo
    ! The error is only needed in the root process since is only going to be written
    call MPI_reduce(InfNorm(u-sol),c,1,MPI_DOUBLE,MPI_MAX,ROOT,MPI_COMM_WORLD,ierr)

    if (me.eq.ROOT) then
      print*, " "
      print*, "---------"
      print*, "SOLUTION"
      print*, "---------"
      print*, "Iterations: ", iter
      print*, "delta : ", deltaALL
      print*, "c : ", c
    endif

    call mpi_barrier(MPI_COMM_WORLD, ierr)
    call mpi_finalize(ierr)
    stop

911 continue
    if(me.eq.ROOT) write(ERROR_UNIT,999) me, errmsg
999 format('MPI process ', i0, ': ', a)
    call mpi_abort(MPI_COMM_WORLD, INTERNAL_ERROR, ierr)

912 continue
    if (me.eq.ROOT) write(*,998) npes
998 format('ERROR: Number of processing elements is not a perfect square. Npes = ',i0)
    call mpi_barrier(MPI_COMM_WORLD, ierr)
    call mpi_abort(MPI_COMM_WORLD, INTERNAL_ERROR, ierr)

!------------------------------------------------------------------------------
!---------------------------------- CONTAINS ----------------------------------
!------------------------------------------------------------------------------
    contains
!------------------------------------------------------------------------------
      function InfNorm(V)
          implicit none
          real(DP), dimension(0:,0:), intent(in) :: V
          real(DP) :: InfNorm

          InfNorm = maxval(maxval(abs(V),1))
      end function InfNorm
!------------------------------------------------------------------------------
      function rhs(x,y,M,N)
        implicit none
        integer , intent(in) :: M, N
        real(DP), dimension(0:M), intent(in) :: x
        real(DP), dimension(0:N), intent(in) :: y
        real(DP), dimension(0:M,0:N) :: rhs

        integer :: i, j

        do i=0,M
          do j=0,N
            rhs(i,j) = exp(x(i)+y(j))*( (x(i)**2d0+3*x(i))*(y(j)**2d0-y(j)) + &
                                            (y(j)**2d0+3*y(j))*(x(i)**2d0-x(i)) )
          enddo
        enddo
      end function rhs
  !------------------------------------------------------------------------------
      function uexact(x,y,M,N)
        implicit none
        integer , intent(in) :: M, N
        real(DP), dimension(0:M), intent(in) :: x
        real(DP), dimension(0:N), intent(in) :: y
        real(DP), dimension(0:M,0:N) :: uexact

        integer :: i, j

        do i=0,M
          do j=0,N
            uexact(i,j)=exp(x(i)+y(j))*(x(i)**2d0-x(i))*(y(j)**2d0-y(j))
          enddo
        enddo
      end function uexact
  !------------------------------------------------------------------------------
      logical function isNotPerfectSquare(n)
          implicit none
          integer, intent(in) :: n
          real :: sqroot

          sqroot = sqrt(real(n))
          if (sqroot == aint(sqroot)) then
            isNotPerfectSquare = .false.
          else
            isNotPerfectSquare = .true.
          endif
      end function
  !------------------------------------------------------------------------------

end program jacobimpi


      double precision function DHINT (X,NDERIV,NTAB,XTAB,YTAB,YPTAB)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DHINT  Krogh   Declared all vars.
C>> 1994-10-20 DHINT  Krogh  Changes to use M77CON
C>> 1987-12-09 DHINT  Lawson  Initial code.
c--D replaces "?": ?HINT
c
c          This subprogram does look-up and Hermite cubic interpolation
c     to evaluate a function at X defined by the data
c     NTAB, XTAB(), YTAB(), & YPTAB().
c     The values in XTAB() must be either strictly increasing or
c     strictly decreasing.
c     Optionally this subprogram will evaluate either the function or
c     its first, second, or third derivative.
c
c     The look-up method is a linear search beginning with the index,
c     LOOK, saved internally from the previous reference to this
c     subprogram.  LOOK is reset if it exceeds the current NTAB.
c     Evaluation at an interior tabular point uses data from the
c     interval in the direction of decreasing abcissa values.
c     Evaluation outside the table (extrapolation) uses data from the
c     nearest tabular interval.
c     ------------------------------------------------------------------
c     Based on subprograms FXDP and DYDXDP by Lawson, Hanson, Lang, and
c     Campbell, JPL, 1968-1974.
c     Modified July 1984 and July 1987 by C. L. Lawson, JPL, for
c     inclusion in the MATH 77 library.
c     ------------------------------------------------------------------
c     X  [in]  Argument at which interpolation is to be done.
c           For best results X should be between XTAB(1) and XTAB(NTAB),
c           however this subprogram will give an extrapolated
c           value when X is outside this range.
c
c     NDERIV  [in]   = 0 to compute function value.
c                    = 1 to compute value of first derivative.
c                    = 2 to compute value of second derivative.
c                    = 3 to compute value of third derivative.
c
c     NTAB  [in]  No. of points in XTAB(), YTAB(), and YPTAB().
c                 Require NTAB .ge. 2.
c
c     XTAB()  [in]  Array of abcissas.  Values must either be strictly
c                   increasing or strictly decreasing.
c
c     YTAB()  [in]  Array of function values.
c                   YTAB(i) = f(XTAB(i))
c
c     YPTAB()  [in]  Array of first derivative values.
c                    YPTAB(i) = f'(XTAB(i))
c     ------------------------------------------------------------------
      integer NDERIV, NTAB, LOOK, LOOK1
      double precision XTAB(NTAB), YTAB(NTAB), YPTAB(NTAB)
      double precision ONE, TWO, THREE, SIX, Q0, Q1, Q2, Q3, Q4, Q5,R,X
      parameter(ONE = 1.0D0, TWO = 2.0D0, THREE = 3.0D0, SIX = 6.0D0)
      save LOOK
      data  LOOK/1/
c     ------------------------------------------------------------------
C
C
      if(XTAB(1) .lt. XTAB(2)) then
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                             Here when values in XTAB() are increasing.
      IF( LOOK .GE. NTAB ) LOOK = max(1,NTAB/2)
C                                      Here  1 .le. LOOK .le. NTAB-1
      IF(X .gt. XTAB(LOOK+1)) GO TO 30
C                 Search toward decreasing abcissae, decreasing indices.
   25 IF(LOOK .eq. 1 ) GO TO 40
      IF(X .gt. XTAB(LOOK)) GO TO 40
      LOOK=LOOK-1
      GO TO 25
C                 Search toward increasing abcissae, increasing indices.
   30 IF(LOOK .eq. NTAB-1) GO TO 40
   35 LOOK=LOOK+1
      IF(LOOK .eq. NTAB-1) GO TO 40
      IF(X .gt. XTAB(LOOK+1)) GO TO 35
   40 LOOK1 = LOOK+1
      else
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                             Here when values in XTAB() are decreasing.
      IF( LOOK .gt. NTAB .or. LOOK .lt. 2 ) LOOK = max(2,NTAB/2)
C
C                         Here  2 .le. LOOK .le. NTAB
C
      IF(X .gt. XTAB(LOOK-1)) GO TO 50
C                 Search toward decreasing abcissae, increasing indices.
   45 IF(LOOK .eq. NTAB ) GO TO 60
      IF(X .gt. XTAB(LOOK)) GO TO 60
      LOOK=LOOK+1
      GO TO 45
C                 Search toward increasing abcissae, decreasing indices.
   50 IF(LOOK .eq. 2) GO TO 60
   55 LOOK=LOOK-1
      IF(LOOK .eq. 2) GO TO 60
      IF(X .gt. XTAB(LOOK-1)) GO TO 55
   60 LOOK1 = LOOK-1
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c              Here XTAB(LOOK) < XTAB(LOOK1) and X is in this interval
c              unless we are extrapolating.
c              Evaluate the Hermite interpolation formulas.
C
      R=XTAB(LOOK1)-XTAB(LOOK)
      Q0=(X-XTAB(LOOK))/R
      Q1=Q0-ONE
C
      go to (100, 101, 102, 103), NDERIV+1
C
  100 Q4=TWO*Q0
      Q2=ONE+Q4
      Q3=THREE-Q4
      Q4=Q1**2
      Q5=Q0**2
      DHINT  =Q4*(Q2*YTAB(LOOK)+R*Q0*YPTAB(LOOK))+
     *        Q5*(Q3*YTAB(LOOK1)+R*Q1*YPTAB(LOOK1))
      return
C
  101 Q2=THREE*Q0
      Q3=SIX*Q0/R
      DHINT  =Q1*(Q3*(YTAB(LOOK)-YTAB(LOOK1))+
     *        (Q2-ONE)*YPTAB(LOOK)) + Q0*(Q2-TWO)*YPTAB(LOOK1)
      return
c
  102 Q2 = Q1 + Q0
      DHINT = (TWO/R) * ( (THREE/R) * (YTAB(LOOK)-YTAB(LOOK1)) * Q2 +
     *        YPTAB(LOOK)*(Q2+Q1) + YPTAB(LOOK1)*(Q2+Q0) )

      return
c
  103 DHINT = (SIX/R**2) * ( (TWO/R) * (YTAB(LOOK)-YTAB(LOOK1)) +
     *                       YPTAB(LOOK) + YPTAB(LOOK1) )
      return
C
      end


module mod_k_means_clustering
    use mod_kinds,              only: ik, rk
    use mod_constants,          only: ZERO, ONE, TWO
    use mod_rbf_tools
    implicit none

contains

    ! Given an array of node coordinates and integer k, this function returns
    ! an array of the indices of the k nodes that are closest to the k-means cluster centers.
    function get_k_means_node_indices(nodes, k) result(center_indices)
        real(rk),       intent(in)  :: nodes(:,:)
        integer(ik),    intent(in)  :: k

        integer(ik) :: center_indices(k)

        real(rk) :: cluster_center(k,3), cluster_center_old(k,3)
        integer(ik) :: nnodes, inode
        integer(ik), allocatable :: cluster_ID(:)
        integer(ik) :: cluster_count(k)

        integer(ik) :: icluster, icenter, num_centers

        real(rk) :: cc_diff, cc_diff_max, dist_test, dist_min, dist_current, tol, dist_max

        logical :: clustering_incomplete = .true.

        nnodes = size(nodes,1)

        tol = 1.0e-5_rk

        allocate(cluster_ID(nnodes))

        !coord_min(1) = minval(nodes(:,1))
        !coord_min(2) = minval(nodes(:,2))
        !coord_min(3) = minval(nodes(:,3))

        !coord_max(1) = maxval(nodes(:,1))
        !coord_max(2) = maxval(nodes(:,2))
        !coord_max(3) = maxval(nodes(:,3))
        ! Randomly assign  initial cluster centers

        !
        ! Perform k-means iteration to find cluster indices
        !

        cluster_center(1,:) = nodes(1,:)
        cluster_ID(1) = 1

        num_centers = 1
        do while (num_centers<k)

            !Loop over the nodes and find the one with the maximal sum of distances to pre-existing cluster centers
            dist_max = 0.0_rk
            do inode = 1, nnodes

                dist_current = 0.0_rk
                do icluster = 1, num_centers

                    dist_current = dist_current + node_dist(nodes(inode,:), cluster_center(icluster,:))**TWO

                end do

                if ((dist_current > dist_max) .and. (.not. any(cluster_ID==inode)) ) then

                    dist_max = dist_current
                    icenter = inode

                end if

            end do

            cluster_ID(num_centers) = icenter
            num_centers = num_centers+1
            cluster_center(num_centers,:) = nodes(icenter,:)
        end do

        !do icluster = 1, k

        !    cluster_center(icluster,:) = nodes(icluster,:)
        !end do
        cluster_center_old = cluster_center
        do while (clustering_incomplete)
            ! Assign nodes to clusters
            do inode = 1, nnodes

                dist_current = 1.0e15_rk
                do icluster = 1, k

                    dist_test = node_dist(nodes(inode,:), cluster_center(icluster,:))

                    if (dist_test < dist_current) then

                        cluster_ID(inode) = icluster
                        dist_current = dist_test

                    end if

                end do

            end do

            ! Recompute cluster centers

            cluster_count = 0
            cluster_center = 0
            do inode = 1, nnodes

                icluster = cluster_ID(inode)
                cluster_count(icluster) = cluster_count(icluster)+1
                cluster_center(icluster,:) = cluster_center(icluster,:) + nodes(inode,:)

            end do

            cc_diff_max = 0
            do icluster = 1,k

                cluster_center(icluster,:) = &
                    (cluster_center(icluster,:)+cluster_center_old(icluster,:))/real(cluster_count(icluster)+1, rk)

                cc_diff = node_dist(cluster_center(icluster,:),cluster_center_old(icluster,:))

                if (cc_diff > cc_diff_max) cc_diff_max = cc_diff
            end do
            cluster_center_old = cluster_center

            clustering_incomplete = (cc_diff_max > tol)

        end do

        ! Loop over each cluster and see which input node is closest to the cluster center, and return this node

        do icluster = 1, k

            dist_min = 1.0e30_rk
            do inode = 1, nnodes

                if (cluster_ID(inode) == icluster) then

                    dist_test = node_dist(nodes(inode,:), cluster_center(icluster,:))

                    if (dist_test < dist_min) then

                        dist_min = dist_test
                        center_indices(icluster) = inode

                    end if

                end if

            end do

        end do

    end function get_k_means_node_indices

end module mod_k_means_clustering


module matrix_tools
    use, intrinsic iso_fortran_env
    use banded_matrices
    use structured_grids

    implicit none

    contains

        ! This function assembles the corresponding laplacian for a given 2D grid.
        ! When assembling the laplacian, we assume the corresponding vector of
        ! unknowns is laid out so that the rows corresponding to varying x-values
        ! (fixed y-values) are laid out end-to-end, starting from the smallest x-value.
        subroutine assemble_laplacian_2d(grid, A)
            type(Grid2D), intent(in) :: grid
            type(banded_matrix), intent(out) :: A

            integer, parameter :: M = grid%nx
            integer, parameter :: N = grid%ny
            real(R64), parameter :: dx = grid%hx
            real(R64), parameter :: dy = grid%hy

            integer, dimension(1:5) :: band_nums = (/ -M, -1, 0, 1, M /)
            integer :: i

            ! Initialize the band matrix.
            call bmat_init(A, .true., .true., M*N, M*N, 2, 2, band_nums)

            ! Set the individual bands of the matrix.
            call bmat_set_band(A, -2, -1 / dy**2)
            call bmat_set_band(A, -1, -1 / dx**2)
            call bmat_set_band(A, 0, 2.0 * ((1 / dx**2) + (1 / dy**2)))
            call bmat_set_band(A, 1, -1 / dx**2)
            call bmat_set_band(A, 2, -1 / dy**2)
        end subroutine assemble_laplacian_2d

        subroutine reshape_unknowns2d(grid, U, V)
            real(R64), dimension(:,:), intent(in) :: U
            real(R64), dimension(:), intent(inout) :: V

            V = reshape(U, SIZE(U(2:SIZE(U, 1), 2:SIZE(U, 2)), 1) * SIZE(U(2:SIZE(U, 1), 2:SIZE(U, 2)), 2))
        end subroutine reshape_unknowns2d+

end module matrix_tools


ccalculate loan payment
c     another way of comment
*  yet another way of comment
      PROGRAM LOAN
      WRITE(*,*) 'amount, percentage rate, and years of loan'
      READ(*,*) AMOUNT, PCRATE, NYEARS
      RATE = PCRATE /100.0
      REPAY = RATE * AMOUNT /(1.0 - (1.0+RATE)**(-NYEARS))
      MTPAY = REPAY/12.0
      WRITE(*,*) 'Annual repayments are ', REPAY
      WRITE(*,*) 'Monthly payment is ', MTPAY
      WRITE(*,*) 'End of year  Balance'
      DO 15, IYEAR = 1,NYEARS
        AMOUNT = AMOUNT +(AMOUNT * RATE) - REPAY
        WRITE(*,'(1X,I9,F11.2)') IYEAR, AMOUNT
c        WRITE(*,*) IYEAR, AMOUNT
15    CONTINUE
      END
c test comments after END