MODULE MOD_BICUB_2D

   !!-----------------------------------------------------------------
   !!
   !!         Method of interpolation : "bicubic 2D"
   !!         =======================================
   !!
   !!    M. Ballarotta, november 2015; Adapated from mod_bilin_2d.f90
   !!    L. Brodeau, october 2012
   !!    P. Mathiot, August 2010
   !!    L. BRODEAU, fall 2008
   !!    J.-M. MOLINES, P. MATHIOT , 2007
   !!
   !!-----------------------------------------------------------------

   USE mod_conf
   USE mod_manip

   IMPLICIT NONE

   LOGICAL, PUBLIC, SAVE :: l_first_call_bicub = .TRUE. !: wether it is the 1st time that bicub_2d is called

   !! To be read into the netcdf file only at "l_first_call_bicub = .TRUE."
   REAL(8), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: RAB       !: alpha, beta
   INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: IMETRICS  !: iP, jP, iquadran at each point

   PRIVATE

   LOGICAL, PARAMETER :: ldebug  = .FALSE.

   LOGICAL  :: lfirst_dist = .TRUE.

   REAL(8), PARAMETER :: rflg = -9999., &
      &                repsilon = 1.E-9

   INTEGER  :: iquadran !: grid sector from 1 to 4 (clockwise, 1=NE) in wich target point
   INTEGER  :: iP, jP   !: location of nearest point on input grid

   PUBLIC :: BICUB_2D

CONTAINS

   SUBROUTINE BICUB_2D(k_ew_per, X10, Y10, Z1, X20, Y20, Z2, cnpat)

      !!================================================================
      !!
      !! INPUT :     k_ew_per : east-west periodicity
      !!                        k_ew_per = -1  --> no periodicity
      !!                        k_ew_per >= 0  --> periodicity with overlap of k_ew_per points
      !!             X10   : 2D input longitude array (ni*nj) or (ni*1)
      !!             Y10   : 2D input latitude  array (ni*nj) or (nj*1)
      !!             Z1    : input field on input grid
      !!
      !!             X20   : 2D output longitude array (ni*nj) or (ni*1)
      !!             Y20   : 2D output latitude  array (ni*nj) or (nj*1)
      !!
      !!             cnpat : name of current configuration pattern
      !!                      -> to recognise the mapping/weight file
      !!
      !! OUTPUT :
      !!             Z2    : input field on output grid
      !!
      !!================================================================

      USE io_ezcdf

      !! Input/Output arguments
      INTEGER,                 INTENT(in)  :: k_ew_per
      REAL(8), DIMENSION(:,:), INTENT(in)  :: X10, Y10
      REAL(4), DIMENSION(:,:), INTENT(in)  :: Z1
      REAL(8), DIMENSION(:,:), INTENT(in)  :: X20, Y20
      REAL(4), DIMENSION(:,:), INTENT(out) :: Z2
      CHARACTER(len=*),      INTENT(in)  :: cnpat

      REAL(8) :: alpha, beta

      !! Local variables
      INTEGER :: nx1, ny1, nx2, ny2
      LOGICAL :: lefw
      INTEGER :: cpt, ji, jj, ni1, nj1, n_ext_per

      REAL(8), DIMENSION(:,:), ALLOCATABLE :: &
         &    X1, Y1, X2, Y2,   &
         &    lon_in , lat_in, Z_in, lat_in_o

      CHARACTER(len=2)   :: ctype

      CHARACTER(LEN=400) :: cf_wght

      REAL(8), DIMENSION(:,:), ALLOCATABLE :: slpx, slpy, slpxy

      ctype = TEST_XYZ(X10,Y10,Z1)
      nx1 = size(Z1,1) ; ny1 = size(Z1,2)
      ALLOCATE ( X1(nx1,ny1) , Y1(nx1,ny1) )

      IF ( ctype == '1d' ) THEN
         DO jj=1, ny1
            X1(:,jj) = X10(:,1)
         END DO
         DO ji=1, nx1
            Y1(ji,:) = Y10(:,1)
         END DO
      ELSE
         X1 = X10 ; Y1 = Y10
      END IF

      ctype = '00'
      ctype = TEST_XYZ(X20, Y20, Z2)
      nx2 = size(Z2,1) ; ny2 = size(Z2,2)
      ALLOCATE ( X2(nx2,ny2) , Y2(nx2,ny2) )

      IF ( ctype == '1d' ) THEN
         DO jj=1, ny2
            X2(:,jj) = X20(:,1)
         END DO
         DO ji=1, nx2
            Y2(ji,:) = Y20(:,1)
         END DO
      ELSE
         X2 = X20 ; Y2 = Y20
      END IF

      !!                       S T A R T

      WRITE(cf_wght,'("sosie_mapping_",a,".nc")') trim(cnpat)

      !! For cleaner results adding the extra band at 4 boundaries :
      n_ext_per=4 ;  ni1 = nx1 + n_ext_per ;  nj1 = ny1 + n_ext_per
      ALLOCATE ( Z_in(ni1,nj1), lon_in(ni1,nj1), lat_in(ni1,nj1), lat_in_o(ni1,nj1) )
      CALL FILL_EXTRA_BANDS(k_ew_per, X1, Y1, REAL(Z1,8), &
         &                           lon_in,   lat_in,    Z_in     )

      DEALLOCATE (X1, Y1)

      ALLOCATE ( slpx(ni1,nj1) , slpy(ni1,nj1) , slpxy(ni1,nj1) )

      !! Computation of partial derivatives:
      CALL PARTIAL_DERIV(k_ew_per, lon_in, lat_in, Z_in, slpx, slpy, slpxy)

      IF ( l_first_call_bicub ) THEN

         !! Testing if the file containing weights exists or if we need to create it
         !! (the latter is very time consuming!!!
         PRINT*,'';PRINT*,'********************************************************'
         INQUIRE(FILE=cf_wght, EXIST=lefw )
         IF ( lefw ) THEN
            PRINT *, 'Mapping file ', trim(cf_wght), ' was found!'
            PRINT *, 'Still! Insure that this is really the one you need!!!'
            PRINT *, 'No need to build it, skipping routine MAPPING !'
         ELSE
            PRINT *, 'No mapping file found in the current directory!'
            PRINT *, 'We are going to build it: ', trim(cf_wght)
            PRINT *, 'This is very time consuming, but only needs to be done once...'
            PRINT *, 'Therefore, you should keep this file for any future interpolation'
            PRINT *, 'using the same "source-target" setup'

            CALL MAPPING(lon_in, lat_in, X2, Y2, cf_wght)

         END IF
         PRINT *, ''; PRINT *, 'MAPPING OK';
         PRINT*,'********************************************************';PRINT*,'';PRINT*,''
      END IF

      Z2 = -777.0      ! Flagging non-interpolated output points

      cpt = 0

      IF ( l_first_call_bicub ) THEN

         ALLOCATE ( IMETRICS(nx2,ny2,3), RAB(nx2,ny2,2) )

         CALL RD_MAPPING_AB(cf_wght, IMETRICS, RAB)
         PRINT *, ''; PRINT *, 'Mapping and weights read into ', trim(cf_wght); PRINT *, ''

      END IF

      DO jj=1, ny2
         DO ji=1, nx2

            iP       = IMETRICS(ji,jj,1)
            jP       = IMETRICS(ji,jj,2)
            iquadran = IMETRICS(ji,jj,3)

            alpha    = RAB(ji,jj,1)
            beta     = RAB(ji,jj,2)

            IF ( (iP == INT(rflg)).OR.(jP == INT(rflg)) ) THEN
               Z2(ji,jj) = rflg
            ELSE

               !! INTERPOLATION !
               Z2(ji,jj) = REAL(INTERP_BC(iP, jP, alpha, beta, Z_in, slpx, slpy, slpxy), 4)

            END IF

         END DO
      END DO

      !! Deallocation :
      DEALLOCATE ( Z_in, lon_in, lat_in, X2, Y2)

      DEALLOCATE ( slpx, slpy, slpxy )

      l_first_call_bicub = .FALSE.

      !!DEALLOCATE ( IMETRICS, RAB )

   END SUBROUTINE BICUB_2D

   FUNCTION INTERP_BC(iP, jP, xa, xb, Z_in, slpx, slpy, slpxy)

      IMPLICIT none

      INTEGER,                 INTENT(in) :: iP, jP
      REAL(8),                 INTENT(in) :: xa, xb
      REAL(8), DIMENSION(:,:), INTENT(in) :: Z_in
      REAL(8), DIMENSION(:,:), INTENT(in) :: slpx, slpy, slpxy

      REAL(8) :: INTERP_BC, &    !wup, &
         &       raa, rbb, xbm1, xam1, xb32, xa32, xxb, xxa, &
         &       w1, w2, w3, w4, w5, w6, w7, w8, &
         &       w9, w10, w11, w12, w13, w14, w15, w16

      INTEGER  :: i1, j1, i2, j2, i3, j3, i4, j4

      !! Choose the 4 interpolation points, according to sector and nearest point (iP, jP)

      !!   o<--o        x<--o         o<--x         o<--o
      !! 1 |   ^ NE   2 |   ^ SE    3 |   ^ SW    4 |   ^ NW
      !!   v   |        v   |         v   |         v   |
      !!   x-->o        o-->o         o-->o         o-->x

      SELECT CASE (iquadran)

      CASE (1)  ! nearest point is the bottom left corner point of local mesh
         i1=iP    ; j1 = jP  ! local mesh is located NE of nearest point
         i2=iP +1 ; j2 = jP
         i3=iP +1 ; j3 = jP + 1
         i4=iP    ; j4 = jP + 1

      CASE (2)  ! nearest point is the top left corner point of mesh
         i1=iP    ; j1 = jP    ! local mesh is located SE of nearest point
         i2=iP    ; j2 = jP - 1
         i3=iP +1 ; j3 = jP - 1
         i4=iP +1 ; j4 = jP

      CASE (3)  ! nearest point is the top righ corner point of mesh
         i1=iP    ; j1 = jP   ! local mesh is located SW of nearest point
         i2=iP -1 ; j2 = jP
         i3=iP -1 ; j3 = jP - 1
         i4=iP    ; j4 = jP - 1

      CASE (4)  ! nearest point is the bottom right corner point of mesh
         i1=iP    ; j1 = jP  ! local mesh is located NW of nearest point
         i2=iP    ; j2 = jP + 1
         i3=iP -1 ; j3 = jP + 1
         i4=iP -1 ; j4 = jP

      END SELECT

      !! compute sum weight above target point

      rbb  = xb*xb
      raa  = xa*xa
      xbm1 = xb - 1.d0
      xam1 = xa - 1.d0
      xb32 = 3.d0 - 2.d0*xb
      xa32 = 3.d0 - 2.d0*xa
      xxb  = ( 1.d0 - rbb * xb32 )
      xxa  = ( 1.d0 - raa * xa32 )

      w1  = xxb * xxa
      w2  = xxb * raa * xa32
      w3  = rbb * xb32 * raa * xa32
      w4  = rbb * xb32 * xxa

      w5  = xxb * xa * xam1*xam1
      w6  = xxb * raa *xam1
      w7  = rbb * xb32 * raa * xam1
      w8  = rbb * xb32 * xa * xam1*xam1
      w9  = xb * xbm1*xbm1 * xxa
      w10 = xb * xbm1*xbm1 * raa * xa32
      w11 = rbb * xbm1 * raa * xa32
      w12 = rbb * xbm1 * xxa

      w13 = xa * xam1*xam1 * xb * xbm1*xbm1
      w14 = raa * xam1 * xb * xbm1*xbm1
      w15 = raa * xam1 * rbb * xbm1
      w16 = xa * xam1*xam1 * rbb * xbm1

      !wup = w1 + w2 + w3 + w4 + &
      !   &  w5 + w6 + w7 + w8 + w9 + w10 + w11 + w12 + &
      !   &  w13 + w14 + w15 + w16

      ! interpolate with non-masked  values, above target point

      !IF ( wup /= 0. ) THEN       ! all points are masked
      INTERP_BC = ( &
         &  Z_in(i1,j1)*w1  +  Z_in(i2,j2)*w2  +  Z_in(i3,j3)*w3  +  Z_in(i4,j4)*w4  + &
         &  slpx(i1,j1)*w5  +  slpx(i2,j2)*w6  +  slpx(i3,j3)*w7  +  slpx(i4,j4)*w8  + &
         &  slpy(i1,j1)*w9  +  slpy(i2,j2)*w10 +  slpy(i3,j3)*w11 +  slpy(i4,j4)*w12 + &
         & slpxy(i1,j1)*w13 + slpxy(i2,j2)*w14 + slpxy(i3,j3)*w15 + slpxy(i4,j4)*w16   &
         & ) !/wup
      ! ELSE
      !    INTERP_BC = 666.
      ! ENDIF

   END FUNCTION INTERP_BC

   SUBROUTINE MAPPING(lon_in, lat_in, lon_out, lat_out, cf_w)

      !!----------------------------------------------------------------------------
      !!            ***  SUBROUTINE MAPPING  ***
      !!
      !!   ** Purpose:  Write file of position, weight need by interpolation
      !!   *  Extract of CDFTOOLS cdfweight.f90 writen by Jean Marc Molines
      !!
      !!
      !!----------------------------------------------------------------------------

      USE io_ezcdf

      IMPLICIT none

      REAL(8), DIMENSION(:,:), INTENT(in) :: lon_in, lat_in
      REAL(8), DIMENSION(:,:), INTENT(in) :: lon_out, lat_out
      CHARACTER(len=400)     , INTENT(in) :: cf_w ! file containing mapping pattern

      INTEGER :: &
         &     nxi, nyi, nxo, nyo, &
         &     ji, jj, ii, &
         &     iP,  jP, niter,   &
         &     iproblem

      REAL(8) ::  &
         &  xP, yP, max_lat_in, min_lat_in, &
         &  emax, hPp, &          !: local maximum metrics
         &  lonP, latP,     &     !: coordinates of the nearest point  (NP)
         &  lonN, latN, hN, &     !: grid point North of NP, true heding from NP
         &  lonE, latE, hE, &     !: grid point East of NP, true heding from NP
         &  lonS, latS, hS, &     !: grid point South of NP, true heding from NP
         &  lonW, latW, hW, &     !: grid point West of NP, true heding from NP
         &  hP,   rdis            !: true heading and distance of target point from NP

      REAL(8), DIMENSION(0:4) :: &
         &    loni, lati    !: the 4 grid points around target (1-4) + the target (0)

      REAL(8), DIMENSION(:,:), ALLOCATABLE :: &
         &    e1, e2, & !: grid layout and metrics
         &    zlon_in, zlat_in

      !! To save in the netcdf file:
      REAL(8), DIMENSION(:,:,:), ALLOCATABLE :: ZAB       !: alpha, beta
      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: MTRCS  !: iP, jP, iquadran at each point
      INTEGER, DIMENSION(:,:),   ALLOCATABLE :: mask_metrics

      LOGICAL  :: lagain     !: additional debug print if ldebug=true

      REAL(8) :: alpha, beta

      nxi = size(lon_in,1)
      nyi = size(lon_in,2)

      nxo = size(lon_out,1)
      nyo = size(lon_out,2)

      ALLOCATE ( e1(nxi,nyi), e2(nxi,nyi), zlon_in(nxi,nyi), zlat_in(nxi,nyi) )

      ALLOCATE ( ZAB(nxo,nyo,2), MTRCS(nxo,nyo,3) )

      ALLOCATE ( mask_metrics(nxo,nyo) )
      mask_metrics(:,:) = 0

      !! We need metric of input grid
      e1(:,:) = 40000. ;  e2(:,:) = 40000.

      DO jj=1, nyi-1
         DO ji=1, nxi-1
            e1(ji,jj) = distance(lon_in(ji,jj),lon_in(ji+1,jj),lat_in(ji,jj),lat_in(ji+1,jj))*1000. !(m)
            e2(ji,jj) = distance(lon_in(ji,jj),lon_in(ji,jj+1),lat_in(ji,jj),lat_in(ji,jj+1))*1000. !(m)
         END DO
      END DO

      e1(nxi,:) = e1(nxi-1,:) ;  e2(nxi,:) = e1(nxi-1,:)
      e1(:,nyi) = e2(:,nyi-1) ;  e2(:,nyi) = e2(:,nyi-1)

      DO ii = 1, nxi
         zlat_in(ii,:) = lat_in(nxi-ii+1,:)
         zlon_in(ii,:) = lon_in(nxi-ii+1,:)
      END DO

      max_lat_in = maxval(lat_in)+1 ! in case grid out a little bite longer
      min_lat_in = minval(lat_in)-1 ! in case grid out a little bite longer

      DO jj = 1, nyo
         DO ji = 1, nxo

            IF ( (ji == 1).AND.(MOD(jj,10)==0) ) PRINT *, ' *** j index =>',jj,'/',nyo

            !! Now deal with horizontal interpolation
            !! set longitude of input point in accordance with lon ( [lon0, 360+lon0 [ )
            xP = lon_out(ji,jj) ;  yP = lat_out(ji,jj)

            lagain = .TRUE. ;   niter = 0

            DO WHILE (lagain)

               IF (niter == 0) THEN
                  IF ( lregin ) THEN
                     CALL FIND_NEAREST_POINT_REG(xP, yP, lon_in, lat_in, iP, jP)
                  ELSE
                     CALL FIND_NEAREST_POINT_IDIOT(xP, yP, lon_in, lat_in, iP, jP)
                  END IF
               END IF

               IF (jP <= 0) jP = 1 !LB
               IF (iP <= 0) iP = 1 !LB

               !! Distance between the target point and the nearest point
               rdis = distance(xP, lon_in(iP,jP), yP, lat_in(iP,jP) )

               ! Typical grid size (diagonal) in the vicinity of nearest point
               emax = MAX(e1(iP,jP),e2(iP,jP))/1000.*SQRT(2.)

               !! Latitude and longitude of the neighbours on the grid
               !! define longitudes between 0 and 360 deg

               IF ((iP-1 == 0).OR.(jP-1 == 0).OR.(iP+1 == nxi+1).OR.(jP+1 == nyi+1)) THEN
                  PRINT *, 'WARNING, mod_bicub_2d.f90: bound problem => ',xP,yP,nxi,nyi,iP,jP
               ELSE
                  lonP = MOD(lon_in(iP,jP)  , 360._8) ; latP = lat_in(iP,jP)   ! nearest point
                  lonN = MOD(lon_in(iP,jP+1), 360._8) ; latN = lat_in(iP,jP+1) ! N (grid)
                  lonE = MOD(lon_in(iP+1,jP), 360._8) ; latE = lat_in(iP+1,jP) ! E (grid)
                  lonS = MOD(lon_in(iP,jP-1), 360._8) ; latS = lat_in(iP,jP-1) ! S (grid)
                  lonW = MOD(lon_in(iP-1,jP), 360._8) ; latW = lat_in(iP-1,jP) ! W (grid)
               END IF

               IF (rdis > emax) THEN
                  !! The nearest point was not found, try one iteration  (jmm ???)
                  IF ( niter <  2 ) THEN
                     lagain = .TRUE.
                     jP   = nyi - 2  ! change initial point
                     niter  = niter + 1
                  ELSE
                     !! Giving up!!!
                     !! set iP, jP to -1000 -1000 ( flag value)
                     lagain = .FALSE.
                     iP = INT(rflg) ; jP = INT(rflg)
                     mask_metrics(ji,jj) = 2
                  ENDIF
               ELSE
                  lagain = .FALSE. ! The nearest point is found
               END IF
            END DO  ! iteration loop

            !! transfer Nearest point to iP, jP
            iP = iP ;  jP = jP

            !! Restore target point longitude between 0 and 360
            xP = MOD(xP,360._8)

            !!LB:
            !! All this HEADING stuf is aimed at finding in which source grid cell
            !! the target point is comprised with regards to the nearest point
            !! (there is actually 4 possible adjacent cells NE, SE, SW and NW)

            !! Compute heading of target point and neighbours from the nearest point
            hP = heading(lonP,  xP,latP,  yP)  ! target point
            hN = heading(lonP,lonN,latP,latN)  ! 'north' on the grid
            hE = heading(lonP,lonE,latP,latE)  ! 'east' on the grid
            hS = heading(lonP,lonS,latP,latS)  ! 'south' on the grid
            hW = heading(lonP,lonW,latP,latW)  ! 'west' on the grid
            !!  => returns an angle !

            !! determine the sector in wich the target point is located:
            !!  ( from 1, to 4 resp. adjacent cells NE, SE, SW, NW  of the grid)
            !!  which mesh from the nearest point point-of-view !
            !!
            !!   o--o        x--o         o--x         o--o
            !! 1 |  | NE   2 |  | SE    3 |  | SW    4 |  | NW
            !!   x--o        o--o         o--o         o--x

            iquadran = 4

            ! to avoid problem with the GW meridian, pass to -180, 180 when working around GW
            IF ( hP > 180. ) THEN
               hPp = hP - 360._8
            ELSE
               hPp = hP
            ENDIF

            IF ( hN > hE ) hN = hN -360._8
            IF ( hPp > hN .AND. hPp <= hE ) iquadran=1
            IF ( hP > hE  .AND. hP <= hS )  iquadran=2
            IF ( hP > hS  .AND. hP <= hW )  iquadran=3
            IF ( hP > hW  .AND. hPp <= hN)  iquadran=4

            loni(0) = xP ;    lati(0) = yP      ! fill loni, lati for 0 = target point
            loni(1) = lonP ;  lati(1) = latP    !                     1 = nearest point

            IF ( iP > INT(rflg) ) THEN
               SELECT CASE ( iquadran ) ! point 2 3 4 are counter clockwise in the respective sector
               CASE ( 1 )
                  loni(2) = lonE ; lati(2) = latE
                  loni(3) = MOD(lon_in(iP+1,jP+1), 360._8) ; lati(3) = lat_in(iP+1,jP+1)
                  loni(4) = lonN ; lati(4) = latN
               CASE ( 2 )
                  loni(2) = lonS ; lati(2) = latS
                  loni(3) = MOD(lon_in(iP+1,jP-1), 360._8) ; lati(3) = lat_in(iP+1,jP-1)
                  loni(4) = lonE ; lati(4) = latE
               CASE ( 3 )
                  loni(2) = lonW ; lati(2) = latW
                  loni(3) = MOD(lon_in(iP-1,jP-1), 360._8) ; lati(3) = lat_in(iP-1,jP-1)
                  loni(4) = lonS ; lati(4) = latS
               CASE ( 4 )
                  loni(2) = lonN ; lati(2) = latN
                  loni(3) = MOD(lon_in(iP-1,jP+1), 360._8) ; lati(3) = lat_in(iP-1,jP+1)
                  loni(4) = lonW ; lati(4) = latW
               END SELECT

               WHERE ( loni <= 0.0 )  loni = loni + 360._8  ! P. Mathiot: Some bug with ERA40 grid

               !! resolve a non linear system of equation for alpha and beta
               !! ( the non dimensional coordinates of target point)
               CALL LOCAL_COORD(loni, lati, alpha, beta, iproblem)
               mask_metrics(ji,jj) = iproblem

            ELSE   ! point is outside the domaine, put dummy values
               alpha = rflg
               beta  = rflg
               mask_metrics(ji,jj) = 1
            ENDIF

            IF (ldebug) THEN
               PRINT *, 'Nearest point :',lonP,  latP,  hP, hPp
               PRINT *, 'North point :',  lonN , latN , hN
               PRINT *, 'East  point :',  lonE , latE , hE
               PRINT *, 'South point :',  lonS , latS , hS
               PRINT *, 'West  point :',  lonW , latW , hW
               PRINT *, 'iquadran =',iquadran
               PRINT *, ''
               PRINT *, ' Nearest 4 points :'
               PRINT *, 'Pt 1 :',loni(1), lati(1)
               PRINT *, 'Pt 2 :',loni(2), lati(2)
               PRINT *, 'Pt 3 :',loni(3), lati(3)
               PRINT *, 'Pt 4 :',loni(4), lati(4)
               PRINT *, ''
            END IF

            !! Saving into arrays to be written at the end:
            MTRCS(ji,jj,:) = (/ iP, jP, iquadran /)
            ZAB(ji,jj,:)      = (/ alpha, beta /)

         ENDDO
      ENDDO

      !! Awkwardly fixing problematic points but remembering them in mask_metrics

      !! Negative values that are actually 0
      WHERE ( ((ZAB(:,:,1) < 0.).AND.(ZAB(:,:,1) > -repsilon)) ) ZAB(:,:,1) = 0.0
      WHERE ( ((ZAB(:,:,2) < 0.).AND.(ZAB(:,:,2) > -repsilon)) ) ZAB(:,:,2) = 0.0

      WHERE ( ((ZAB(:,:,1) < 0.).AND.(ZAB(:,:,1) > rflg)).OR.(ZAB(:,:,1) > 1.) )
         ZAB(:,:,1) = 0.5
         mask_metrics(:,:) = 3
      END WHERE

      WHERE ( ((ZAB(:,:,2) < 0.).AND.(ZAB(:,:,2) > rflg)).OR.(ZAB(:,:,2) > 1.) )
         ZAB(:,:,2) = 0.5
         mask_metrics(:,:) = mask_metrics(:,:) + 10
      END WHERE

      !! Print metrics and weight into a netcdf file 'cf_w':
      CALL P2D_MAPPING_AB(cf_w, lon_out, lat_out, MTRCS, ZAB, rflg, mask_metrics)

      DEALLOCATE ( e1 , e2 , zlon_in , zlat_in )
      DEALLOCATE ( MTRCS, ZAB, mask_metrics )

   END SUBROUTINE MAPPING

   SUBROUTINE LOCAL_COORD(xlam, xphi, xa, xb, ipb)

      !!----------------------------------------------------------
      !!           ***  SUBROUTINE  local_coord    ***
      !!
      !!  ** Purpose : Compute the local coordinate in a grid cell
      !!
      !!  ** Method : from N. Daget Web page :
      !!       http://aton.cerfacs.fr/~daget/TECHREPORT/TR_CMGC_06_18_html/node8.html
      !!
      !! * history:
      !!      Original : J.M. Molines ( May 2007)
      !!----------------------------------------------------------

      IMPLICIT NONE

      !! * Arguments
      REAL(8), DIMENSION(0:4), INTENT(in)  :: xlam, xphi
      REAL(8)                , INTENT(out) :: xa, xb
      INTEGER                , INTENT(out) :: ipb  !: 0 if everything went fine, > 0 otherwize!

      !! * Local variables
      REAL(8) :: &
         &      zalpha=0. , zbeta=0., zresmax=0.1, zres, &
         &      zdeta, zdalp, zdbet, zdlam, zdphi, z1, z2, z3

      REAL(8), DIMENSION(2,2):: za
      REAL(8), DIMENSION(0:4):: zxlam

      INTEGER :: niter=0

      INTEGER, PARAMETER :: itermax=200 !: maximum of iteration

      ipb = 0

      zxlam = xlam       !: save input longitude in workinh array

      IF ((ABS(zxlam(1)-zxlam(4))>=180.).OR.(ABS(zxlam(1)-zxlam(2))) >= 180. &
         &                            .OR.(ABS(zxlam(1)-zxlam(3))  >= 180. )) THEN
         ! then we are near the 0 deg line and we must work in the frame -180 180
         WHERE ( zxlam >= 180. ) zxlam=zxlam -360._8
      ENDIF

      zres=1000. ; zdlam=0.5 ;  zdphi=0.5 ;  zalpha=0. ;  zbeta=0. ;  niter=0

      DO WHILE ( (zres > zresmax).AND.(niter < itermax) )

         z1 = (zxlam(2) - zxlam(1))
         z2 = (zxlam(1) - zxlam(4))
         z3 = (zxlam(3) - zxlam(2))

         za(1,1) =  z1 + (z2 + z3 )*zbeta
         za(1,2) = -z2 + (z2 + z3 )*zalpha

         za(2,1) = xphi(2) - xphi(1) + (xphi(1) - xphi(4) + xphi(3) - xphi(2))*zbeta
         za(2,2) = xphi(4) - xphi(1) + (xphi(1) - xphi(4) + xphi(3) - xphi(2))*zalpha

         ! Determinant
         zdeta = det(za(1,1), za(1,2), za(2,1), za(2,2) )

         !! Solution of
         !! | zdlam |        | zdalp |
         !! |       | =  za .|       |
         !! | zdphi |        | zdbet |

         zdeta = ( SIGN(1._8,zdeta)*MAX(ABS(zdeta), repsilon) )  ! just to avoid FPE division by zero sometimes...

         zdalp = det(zdlam,  za(1,2) , zdphi, za(2,2)  ) / zdeta
         zdbet = det(za(1,1)  , zdlam, za(2,1)   ,zdphi) / zdeta

         !! Compute residual ( loop criteria)
         zres = sqrt(zdalp*zdalp + zdbet*zdbet )

         !! Compute alpha and beta from 1rst guess :
         zalpha = zalpha + zdalp
         zbeta  = zbeta  + zdbet

         !! Compute corresponding lon/lat for this alpha, beta
         zdlam = zxlam(0) - ((1.-zalpha)*(1-zbeta)*zxlam(1) + zalpha*(1-zbeta)*zxlam(2)  &
            &                    +  zalpha*zbeta*zxlam(3) + (1-zalpha)*zbeta*zxlam(4))
         zdphi = xphi(0)  - ((1.-zalpha)*(1-zbeta)*xphi(1)  + zalpha*(1-zbeta)*xphi(2)   &
            &                    +  zalpha*zbeta*xphi(3)  + (1-zalpha)*zbeta*xphi(4))

         niter = niter + 1  ! increment iteration counter

      END DO   ! loop until zres small enough (or itermax reach )

      IF ( niter >= itermax )   THEN
         !IF ( maxval(xphi) < 89. ) THEN
         !   PRINT *, ''
         !   PRINT *, 'LOCAL_COORD of mod_bicub_2d.f90: problematic region found!!!!'
         !   PRINT *, ' --> relax, this may only occur on your masked regions...'
         !   PRINT *, ''
         !   PRINT *, ' *** input longitude:', xlam ; PRINT *, ''
         !   PRINT *, ' *** input latitude:' , xphi ; PRINT *, ''
         !END IF
         zalpha = 0.5 ; zbeta  = 0.5 ; ipb = 5
      END IF

      xa = zalpha
      xb = zbeta

      !! Problem if the 4 latitudes surrounding 'lati' are equal!
      IF ( (xphi(1)==xphi(2)).and.(xphi(2)==xphi(3)).and.(xphi(3)==xphi(4)) ) THEN
         xa = 0.5
         xb = 0.5
         ipb = 10
      END IF

   END SUBROUTINE LOCAL_COORD

   FUNCTION det(p1, p2, p3, p4)
      !!----------------------------------------------------------
      !!          ***  FUNCTION DET   ***
      !!
      !!    ** Purpose : compute determinant
      !!
      !! * history:
      !!     J.M. Molines may 2007
      !!----------------------------------------------------------
      IMPLICIT NONE
      REAL(8),INTENT(in) :: p1, p2, p3, p4
      REAL(8) :: det
      det = p1*p4 - p2*p3
   END FUNCTION det

   FUNCTION heading(plona, plonb, plata, platb)

      !!--------------------------------------------------------------
      !!           ***   FUNCTION HEADING   ***
      !!
      !!   ** Purpose: Compute true heading between point a and b
      !!
      !!   ** Method : suppose that the 2 points are not too far away from each other
      !!            so that heading can be computed with loxodromy
      !!
      !!  * history
      !!         J.M. Molines, may 2007
      !!--------------------------------------------------------------

      IMPLICIT NONE
      !!  Arguments
      REAL(8), INTENT(in) :: plata, plona, platb, plonb
      REAL(8) :: heading

      !!  Local variables
      REAL(8)  :: zpi, zconv, angled, xa, xb, ya, yb, xb_xa, rr

      zpi=ACOS(-1._8)
      zconv=zpi/180.  ! for degree to radian conversion

      !! There is a problem if the Greenwich meridian pass between a and b
      IF ( ldebug) print *,' Plonb  Plona ' , plonb, plona
      xa=plona*zconv
      xb=plonb*zconv

      rr = MAX(ABS(tan(zpi/4.-zconv*plata/2.)), repsilon)  !lolo just to avoid FPE sometimes
      ya = -LOG(rr)

      rr = MAX(ABS(tan(zpi/4.-zconv*platb/2.)), repsilon)  !lolo just to avoid FPE sometimes
      yb = -LOG(rr)

      IF (ldebug) PRINT *,' xa_xb , modulo 2pi', xb-xa, MOD((xb-xa),2*zpi)
      xb_xa=MOD((xb-xa),2*zpi)

      IF ( xb_xa >= zpi ) xb_xa = xb_xa -2*zpi
      IF ( xb_xa <= - zpi ) xb_xa = xb_xa +2*zpi
      IF (ldebug)  print *, 'yb -ya, xb_xa ',yb -ya , xb_xa

      angled = ATAN2(xb_xa, yb - ya)

      heading=angled*180./zpi
      IF (heading < 0) heading = heading + 360._8

   END FUNCTION heading

END MODULE MOD_BICUB_2D


! { dg-do run }
! PR13415
! Test pointer variables in common blocks.

subroutine test
  implicit none
  real, pointer :: p(:), q
  common /block/ p, q

  if (any (p .ne. (/1.0, 2.0/)) .or. (q .ne. 42.0)) call abort ()
end subroutine

program common_pointer_1
  implicit none
  real, target :: a(2), b
  real, pointer :: x(:), y
  common /block/ x, y

  a = (/1.0, 2.0/)
  b = 42.0
  x=>a
  y=>b
  call test
end program


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
module complex_linear_systems_solver

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip, & ! Integer precision
        PI

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: cmgnbn

    ! Parameters confined to the module
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: HALF = 0.5_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    real(wp),    parameter :: THREE = 3.0_wp
    real(wp),    parameter :: FOUR = 4.0_wp
    integer(ip), parameter :: IIWK = 11 ! Size of workspace_indices

contains
    !
    !     SUBROUTINE cmgnbn(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
    !
    !
    ! DIMENSION OF           a(m), b(m), c(m), y(idimy, n)
    ! ARGUMENTS
    !
    ! PURPOSE                The name of this package is a mnemonic for the
    !                        complex generalized Buneman algorithm.
    !                        it solves the complex linear system of equation
    !
    !                        a(i)*x(i-1, j) + b(i)*x(i, j) + c(i)*x(i+1, j)
    !                        + x(i, j-1) - TWO * x(i, j) + x(i, j+1) = y(i, j)
    !
    !                        for i = 1, 2, ..., m  and  j = 1, 2, ..., n.
    !
    !                        indices i+1 and i-1 are evaluated modulo m,
    !                        i.e., x(0, j) = x(m, j) and x(m+1, j) = x(1, j),
    !                        and x(i, 0) may equal 0, x(i, 2), or x(i, n),
    !                        and x(i, n+1) may equal 0, x(i, n-1), or x(i, 1)
    !                        depending on an input parameter.
    !
    ! USAGE                  call cmgnbn (nperod, n, mperod, m, a, b, c, idimy, y,
    !                                     ierror)
    !
    ! ARGUMENTS
    !
    ! ON INPUT               nperod
    !
    !                          indicates the values that x(i, 0) and
    !                          x(i, n+1) are assumed to have.
    !
    !                          = 0  if x(i, 0) = x(i, n) and x(i, n+1) =
    !                               x(i, 1).
    !                          = 1  if x(i, 0) = x(i, n+1) = 0  .
    !                          = 2  if x(i, 0) = 0 and x(i, n+1) = x(i, n-1).
    !                          = 3  if x(i, 0) = x(i, 2) and x(i, n+1) =
    !                               x(i, n-1).
    !                          = 4  if x(i, 0) = x(i, 2) and x(i, n+1) = 0.
    !
    !                        n
    !                          the number of unknowns in the j-direction.
    !                          n must be greater than 2.
    !
    !                        mperod
    !                          = 0 if a(1) and c(m) are not zero
    !                          = 1 if a(1) = c(m) = 0
    !
    !                        m
    !                          the number of unknowns in the i-direction.
    !                          n must be greater than 2.
    !
    !                        a, b, c
    !                          one-dimensional complex arrays of length m
    !                          that specify the coefficients in the linear
    !                          equations given above.  if mperod = 0
    !                          the array elements must not depend upon
    !                          the index i, but must be constant.
    !                          specifically, the subroutine checks the
    !                          following condition .
    !
    !                            a(i) = c(1)
    !                            c(i) = c(1)
    !                            b(i) = b(1)
    !
    !                          for i=1, 2, ..., m.
    !
    !                        idimy
    !                          the row (or first) dimension of the
    !                          two-dimensional array y as it appears
    !                          in the program calling cmgnbn.
    !                          this parameter is used to specify the
    !                          variable dimension of y.
    !                          idimy must be at least m.
    !
    !                        y
    !                          a two-dimensional complex array that
    !                          specifies the values of the right side
    !                          of the linear system of equations given
    !                          above.
    !                          y must be dimensioned at least m*n.
    !
    !
    !  ON OUTPUT             y
    !
    !                          contains the solution x.
    !
    !                        ierror
    !                          an error flag which indicates invalid
    !                          input parameters  except for number
    !                          zero, a solution is not attempted.
    !
    !                          = 0  no error.
    !                          = 1  m <= 2  .
    !                          = 2  n <= 2
    !                          = 3  idimy < m
    !                          = 4  nperod < 0 or nperod > 4
    !                          = 5  mperod < 0 or mperod > 1
    !                          = 6  a(i) /= c(1) or c(i) /= c(1) or
    !                               b(i) /= b(1) for
    !                               some i=1, 2, ..., m.
    !                          = 7  a(1) /= 0 or c(m) /= 0 and
    !                                 mperod = 1
    !                          = 20 if the dynamic allocation of real and
    !                               complex workspace required for solution
    !                               fails (for example if n, m are too large
    !                               for your computer)
    !
    ! HISTORY                Written in 1979 by Roland Sweet of NCAR'S
    !                        scientific computing division. Made available
    !                        on NCAR's public libraries in January, 1980.
    !                        Revised in June 2004 by John Adams using
    !                        Fortran 90 dynamically allocated workspace.
    !
    ! ALGORITHM              The linear system is solved by a cyclic
    !                        reduction algorithm described in the
    !                        reference below.
    !
    ! REFERENCES             Sweet, R., 'A cyclic reduction algorithm for
    !                        solving block tridiagonal systems of arbitrary
    !                        dimensions, ' SIAM J. on Numer. Anal.,
    !                          14(Sept., 1977), pp. 706-720.
    !
    ! ACCURACY               this test was performed on a platform with
    !                        64 bit floating point arithmetic.
    !                        a uniform random number generator was used
    !                        to create a solution array x for the system
    !                        given in the 'purpose' description above
    !                        with
    !                          a(i) = c(i) = -0.5 * b(i) = 1, i=1, 2, ..., m
    !
    !                        and, when mperod = 1
    !
    !                          a(1) = c(m) = 0
    !                          a(m) = c(1) = 2.
    !
    !                        the solution x was substituted into the
    !                        given system  and a right side y was
    !                        computed.  using this array y, subroutine
    !                        cmgnbn was called to produce approximate
    !                        solution z.  then relative error
    !                          e = max(abs(z(i, j)-x(i, j)))/
    !                              max(abs(x(i, j)))
    !                        was computed, where the two maxima are taken
    !                        over i=1, 2, ..., m and j=1, ..., n.
    !
    !                        the value of e is given in the table
    !                        below for some typical values of m and n.
    !
    !                   m (=n)    mperod    nperod       e
    !                   ------    ------    ------     ------
    !
    !                     31        0         0        1.e-12
    !                     31        1         1        4.e-13
    !                     31        1         3        2.e-12
    !                     32        0         0        7.e-14
    !                     32        1         1        5.e-13
    !                     32        1         3        2.e-13
    !                     33        0         0        6.e-13
    !                     33        1         1        5.e-13
    !                     33        1         3        3.e-12
    !                     63        0         0        5.e-12
    !                     63        1         1        6.e-13
    !                     63        1         3        1.e-11
    !                     64        0         0        1.e-13
    !                     64        1         1        3.e-12
    !                     64        1         3        3.e-13
    !                     65        0         0        2.e-12
    !                     65        1         1        5.e-13
    !                     65        1         3        1.e-11
    !
    !
    subroutine cmgnbn(nperod, n, mperod, m, a, b, c, idimy, y, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: nperod
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: mperod
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: idimy
        integer(ip), intent(out)    :: ierror
        complex(wp), intent(in)     :: a(:)
        complex(wp), intent(in)     :: b(:)
        complex(wp), intent(in)     :: c(:)
        complex(wp), intent(inout)  :: y(:,:)

        ! Local variables
        type(FishpackWorkspace) :: workspace

        ! Check input arguments
        call check_input_arguments(nperod, n, mperod, m, a, b, c, idimy, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call initialize_workspace(n, m, workspace)

        ! Solve system
        associate( &
            cxw => workspace%complex_workspace, &
            indx => workspace%workspace_indices &
            )
            call cmgnbn_lower_routine(nperod, n, mperod, m, a, b, c, idimy, y, cxw, indx)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine cmgnbn

    pure subroutine check_input_arguments(nperod, n, mperod, m, a, b, c, idimy, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: nperod
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: mperod
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: idimy
        integer(ip), intent(out)    :: ierror
        complex(wp), intent(in)     :: a(:)
        complex(wp), intent(in)     :: b(:)
        complex(wp), intent(in)     :: c(:)

        if (3 > m) then
            ierror = 1
            return
        else if (3 > n) then
            ierror = 2
            return
        else if (idimy < m) then
            ierror = 3
            return
        else if (nperod < 0 .or. nperod > 4) then
            ierror = 4
            return
        else if (mperod < 0 .or. mperod > 1) then
            ierror = 5
            return
        else if (mperod /= 1) then
            if (any(abs(a(2:m)-c(1)) /= ZERO) .or. &
                any(abs(c(2:m)-c(1)) /= ZERO) .or. &
                any(abs(b(2:m)-b(1)) /= ZERO)) then
                ierror = 6
                return
            end if
        else if (abs(a(1)) /= ZERO .and. abs(c(m)) /= ZERO) then
            ierror = 7
            return
        else
            ierror = 0
        end if

    end subroutine check_input_arguments

    subroutine initialize_workspace(n, m, workspace)

        ! Dummy arguments
        integer(ip),              intent(in)  :: n
        integer(ip),              intent(in)  :: m
        class(FishpackWorkspace), intent(out) :: workspace

        ! Local variables
        integer(ip) :: irwk, icwk, j

        ! Compute required workspace sizes
        irwk = 0
        icwk = (10 + int(log(real(n, kind=wp))/log(TWO), kind=ip))*m + 4*n

        ! Allocate memory
        call workspace%create(irwk, icwk, IIWK)

        ! Compute workspace indices
        associate( indx => workspace%workspace_indices )
            indx(1) = m + 1
            do j = 1, IIWK - 2
                indx(j + 1) = indx(j) + m
            end do
            indx(IIWK) = indx(IIWK-1) + 4*n
        end associate

    end subroutine initialize_workspace

    subroutine cmgnbn_lower_routine(nperod, n, mperod, m, a, b, c, idimy, y, w, workspace_indices)

        ! Dummy arguments
        integer(ip), intent(in)     :: nperod
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: mperod
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: idimy
        complex(wp), intent(in)     :: a(:)
        complex(wp), intent(in)     :: b(:)
        complex(wp), intent(in)     :: c(:)
        complex(wp), intent(inout)  :: y(:,:)
        complex(wp), intent(out)    :: w(:)
        integer(ip), intent(in)     :: workspace_indices(:)

        ! Local variables
        integer(ip) :: i, k, j, mp, np, ipstor
        integer(ip) :: irev, mh, mhm1, modd, nby2, mskip
        complex(wp) :: temp_save

        associate( &
            iwba => workspace_indices(1), &
            iwbb => workspace_indices(2), &
            iwbc => workspace_indices(3), &
            iwb2 => workspace_indices(4), &
            iwb3 => workspace_indices(5), &
            iww1 => workspace_indices(6), &
            iww2 => workspace_indices(7), &
            iww3 => workspace_indices(8), &
            iwd => workspace_indices(9), &
            iwtcos => workspace_indices(10), &
            iwp => workspace_indices(11) &
            )

            do i = 1, m
                k = iwba + i - 1
                w(k) = -a(i)
                k = iwbc + i - 1
                w(k) = -c(i)
                k = iwbb + i - 1
                w(k) = TWO - b(i)
                y(i, :n) = -y(i, :n)
            end do

            mp = mperod + 1
            np = nperod + 1

            select case (mp)
                case (1)
                    goto 114
                case (2)
                    goto 107
            end select
107     continue
        select case (np)
            case (1)
                goto 108
            case (2)
                goto 109
            case (3)
                goto 110
            case (4)
                goto 111
            case (5)
                goto 123
        end select
108 continue
    call solve_poisson_periodic(m, n, w(iwba:), w(iwbb:), w(iwbc:), y, idimy, w, &
        w(iwb2:), w(iwb3:), w(iww1:), w(iww2:), w(iww3:), w(iwd:), w(iwtcos:), w(iwp:))
    goto 112
109 continue
    call solve_poisson_dirichlet(m, n, 1, w(iwba:), w(iwbb:), w(iwbc:), y, idimy, w, &
        w(iww1:), w(iwd:), w(iwtcos:), w(iwp:))
    goto 112
110 continue
    call solve_poisson_neumann(m, n, 1, 2, w(iwba:), w(iwbb:), w(iwbc:), y, idimy, w, &
        w(iwb2:), w(iwb3:), w(iww1:), w(iww2:), w(iww3:), w(iwd:), w(iwtcos:), w(iwp:))
    goto 112
111 continue
    call solve_poisson_neumann(m, n, 1, 1, w(iwba:), w(iwbb:), w(iwbc:), y, idimy, w, &
        w(iwb2:), w(iwb3:), w(iww1:), w(iww2:), w(iww3:), w(iwd:), w(iwtcos:), w(iwp:))
112 continue

    ipstor = int(w(iww1), kind=ip)
    irev = 2

    if (nperod == 4) goto 124

113 continue

    select case (mp)
        case (1)
            goto 127
        case (2)
            w(1) = cmplx(real(ipstor + iwp - 1, kind=wp), ZERO, kind=wp)
            return
    end select
114 continue

    mh = (m + 1)/2
    mhm1 = mh - 1

    if (mh*2 == m) then
        modd = 2
    else
        modd = 1
    end if

    do j = 1, n
        do i = 1, mhm1
            w(i) = y(mh-i, j) - y(i+mh, j)
            w(i+mh) = y(mh-i, j) + y(i+mh, j)
        end do
        w(mh) = TWO * y(mh, j)
        select case (modd)
            case (1)
                y(:m, j) = w(:m)
            case (2)
                w(m) = TWO * y(m, j)
                y(:m, j) = w(:m)
        end select
    end do

    k = iwbc + mhm1 - 1
    i = iwba + mhm1
    w(k) = ZERO
    w(i) = ZERO
    w(k+1) = TWO * w(k+1)

    select case (modd)
        case default
            k = iwbb + mhm1 - 1
            w(k) = w(k) - w(i-1)
            w(iwbc-1) = w(iwbc-1) + w(iwbb-1)
        case (2)
            w(iwbb-1) = w(k+1)
    end select

    goto 107
!
!     reverse columns when nperod = 4
!

123 continue

    irev = 1
    nby2 = n/2

124 continue

    do j = 1, nby2
        mskip = n + 1 - j
        do i = 1, m
            temp_save = y(i, j)
            y(i, j) = y(i, mskip)
            y(i, mskip) = temp_save
        end do
    end do

    select case (irev)
        case (1)
            goto 110
        case (2)
            goto 113
    end select

127 continue

    do j = 1, n
        w(mh-1:mh-mhm1:(-1)) = HALF * (y(mh+1:mhm1+mh, j)+y(:mhm1, j))
        w(mh+1:mhm1+mh) = HALF * (y(mh+1:mhm1+mh, j)-y(:mhm1, j))
        w(mh) = HALF * y(mh, j)
        select case (modd)
            case (1)
                y(:m, j) = w(:m)
            case (2)
                w(m) = HALF * y(m, j)
                y(:m, j) = w(:m)
        end select
    end do

    w(1) = cmplx(real(ipstor + iwp - 1, kind=wp), ZERO, kind=wp)

end associate

end subroutine cmgnbn_lower_routine

! Purpose:
!
!     To solve poisson's equation for dirichlet boundary
!     conditions.
!
!     istag = 1 if the last diagonal block is the matrix a.
!     istag = 2 if the last diagonal block is the matrix a+i.
!
subroutine solve_poisson_dirichlet(mr, nr, istag, ba, bb, bc, q, idimq, b, w, d, tcos, p)

    ! Dummy arguments
    integer(ip), intent(in)     :: mr
    integer(ip), intent(in)     :: nr
    integer(ip), intent(in)     :: istag
    integer(ip), intent(in)     :: idimq
    complex(wp), intent(in)     :: ba(mr)
    complex(wp), intent(in)     :: bb(mr)
    complex(wp), intent(in)     :: bc(mr)
    complex(wp), intent(inout) :: q(idimq,nr)
    complex(wp), intent(inout) :: b(mr)
    complex(wp), intent(inout) :: w(mr)
    complex(wp), intent(inout) :: d(mr)
    complex(wp), intent(inout) :: tcos(mr)
    complex(wp), intent(inout) :: p(nr*4)

    ! Local variables
    integer(ip) :: m, n, iip, ipstor, jsh, kr, irreg, jstsav, i, lr, nun
    integer(ip) :: jst, jsp, l, nodd, j, jm1, jp1, jm2, jp2, jm3, jp3, noddpr
    integer(ip) :: krpi, ideg, jdeg
    real(wp)    :: fi
    complex(wp) :: t

    m = mr
    n = nr
    fi = ONE/istag
    iip = -m
    ipstor = 0
    jsh = 0

    select case (istag)
        case default
            kr = 0
            irreg = 1
            if (n > 1) goto 106
            tcos(1) = ZERO
        case (2)
            kr = 1
            jstsav = 1
            irreg = 2
            if (n > 1) goto 106
            tcos(1) = cmplx(-ONE, ZERO, kind=wp)
    end select

    b(:m) = q(:m, 1)
    call solve_linear_system(1, 0, m, ba, bb, bc, b, tcos, d, w)
    q(:m, 1) = b(:m)
    goto 183
106 continue
    lr = 0
    p(1:m) = ZERO
    nun = n
    jst = 1
    jsp = n
!
!     irreg = 1 when no irregularities have occurred, otherwise it is 2.
!
108 continue
    l = 2*jst
    nodd = 2 - 2*((nun + 1)/2) + nun
    !
    !     nodd = 1 when nun is odd, otherwise it is 2.
    !
    select case (nodd)
        case default
            jsp = jsp - l
        case (1)
            jsp = jsp - jst
            if (irreg /= 1) jsp = jsp - l
    end select

    call generate_cosines(jst, 1, HALF, ZERO, tcos)

    if (l <= jsp) then
        do j = l, jsp, l
            jm1 = j - jsh
            jp1 = j + jsh
            jm2 = j - jst
            jp2 = j + jst
            jm3 = jm2 - jsh
            jp3 = jp2 + jsh
            if (jst == 1) then
                b(:m) = TWO * q(:m, j)
                q(:m, j) = q(:m, jm2) + q(:m, jp2)
            else
                do i = 1, m
                    t = q(i, j) - q(i, jm1) - q(i, jp1) + q(i, jm2) + q(i, jp2)
                    b(i) = t + q(i, j) - q(i, jm3) - q(i, jp3)
                    q(i, j) = t
                end do
            end if
            call solve_linear_system(jst, 0, m, ba, bb, bc, b, tcos, d, w)
            q(:m, j) = q(:m, j) + b(:m)
        end do
    end if
    !
    !     reduction for last unknown
    !
    select case (nodd)
        case default
            select case (irreg)
                case (1)
                    goto 152
                case (2)
                    goto 120
            end select
        !
        !     odd number of unknowns
        !
120     continue
        jsp = jsp + l
        j = jsp
        jm1 = j - jsh
        jp1 = j + jsh
        jm2 = j - jst
        jp2 = j + jst
        jm3 = jm2 - jsh
        select case (istag)
            case (1)
                goto 123
            case (2)
                goto 121
        end select
121 continue
    if (jst /= 1) goto 123
    do i = 1, m
        b(i) = q(i, j)
        q(i, j) = ZERO
    end do
    goto 130
123 continue
    select case (noddpr)
        case default
            b(:m) = HALF * (q(:m, jm2)-q(:m, jm1)-q(:m, jm3)) + p(iip+1:m+iip) &
                + q(:m, j)
        case (2)
            b(:m) = HALF * (q(:m, jm2)-q(:m, jm1)-q(:m, jm3)) + q(:m, jp2) - q( &
                :m, jp1) + q(:m, j)
    end select

    q(:m, j) = HALF * (q(:m, j)-q(:m, jm1)-q(:m, jp1))
130 continue
    call solve_linear_system(jst, 0, m, ba, bb, bc, b, tcos, d, w)
    iip = iip + m
    ipstor = max(ipstor, iip + m)
    p(iip+1:m+iip) = q(:m, j) + b(:m)
    b(:m) = q(:m, jp2) + p(iip+1:m+iip)
    if (lr == 0) then
        do i = 1, jst
            krpi = kr + i
            tcos(krpi) = tcos(i)
        end do
    else
        call generate_cosines(lr, jstsav, ZERO, fi, tcos(jst+1))
        call merge_tcos(tcos, 0, jst, jst, lr, kr)
    end if
    call generate_cosines(kr, jstsav, ZERO, fi, tcos)
    call solve_linear_system(kr, kr, m, ba, bb, bc, b, tcos, d, w)
    q(:m, j) = q(:m, jm2) + b(:m) + p(iip+1:m+iip)
    lr = kr
    kr = kr + l
!
!     even number of unknowns
!
case (2)
    jsp = jsp + l
    j = jsp
    jm1 = j - jsh
    jp1 = j + jsh
    jm2 = j - jst
    jp2 = j + jst
    jm3 = jm2 - jsh
    select case (irreg)
        case default
            jstsav = jst
            ideg = jst
            kr = l
        case (2)
            call generate_cosines(kr, jstsav, ZERO, fi, tcos)
            call generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1))
            ideg = kr
            kr = kr + jst
    end select

    if (jst == 1) then
        irreg = 2
        b(:m) = q(:m, j)
        q(:m, j) = q(:m, jm2)
    else
        b(:m) = q(:m, j) + HALF * (q(:m, jm2)-q(:m, jm1)-q(:m, jm3))
        select case (irreg)
            case default
                q(:m, j) = q(:m, jm2) + HALF * (q(:m, j)-q(:m, jm1)-q(:m, jp1))
                irreg = 2
            case (2)
                select case (noddpr)
                    case default
                        q(:m, j) = q(:m, jm2) + p(iip+1:m+iip)
                        iip = iip - m
                    case (2)
                        q(:m, j) = q(:m, jm2) + q(:m, j) - q(:m, jm1)
                end select
        end select
    end if

    call solve_linear_system(ideg, lr, m, ba, bb, bc, b, tcos, d, w)
    q(:m, j) = q(:m, j) + b(:m)
end select
152 continue
    nun = nun/2
    noddpr = nodd
    jsh = jst
    jst = 2*jst
    if (nun >= 2) goto 108
    !
    !     start solution.
    !
    j = jsp
    b(:m) = q(:m, j)
    select case (irreg)
        case default
            call generate_cosines(jst, 1, HALF, ZERO, tcos)
            ideg = jst
        case (2)
            kr = lr + jst
            call generate_cosines(kr, jstsav, ZERO, fi, tcos)
            call generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1))
            ideg = kr
    end select

    call solve_linear_system(ideg, lr, m, ba, bb, bc, b, tcos, d, w)
    jm1 = j - jsh
    jp1 = j + jsh
    select case (irreg)
        case default
            q(:m, j) = HALF * (q(:m, j)-q(:m, jm1)-q(:m, jp1)) + b(:m)
        case (2)
            select case (noddpr)
                case default
                    q(:m, j) = p(iip+1:m+iip) + b(:m)
                    iip = iip - m
                case (2)
                    q(:m, j) = q(:m, j) - q(:m, jm1) + b(:m)
            end select
    end select
164 continue
    jst = jst/2
    jsh = jst/2
    nun = 2*nun
    if (nun > n) goto 183
    do j = jst, n, l
        jm1 = j - jsh
        jp1 = j + jsh
        jm2 = j - jst
        jp2 = j + jst
        if (j <= jst) then
            b(:m) = q(:m, j) + q(:m, jp2)
        else
            if (jp2 <= n) goto 168
            b(:m) = q(:m, j) + q(:m, jm2)
            if (jst < jstsav) irreg = 1
            select case (irreg)
                case (1)
                    goto 170
                case (2)
                    goto 171
            end select
168     continue
        b(:m) = q(:m, j) + q(:m, jm2) + q(:m, jp2)
    end if
170 continue
    call generate_cosines(jst, 1, HALF, ZERO, tcos)
    ideg = jst
    jdeg = 0
    goto 172
171 continue
    if (j + l > n) lr = lr - jst
    kr = jst + lr
    call generate_cosines(kr, jstsav, ZERO, fi, tcos)
    call generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1))
    ideg = kr
    jdeg = lr
172 continue
    call solve_linear_system(ideg, jdeg, m, ba, bb, bc, b, tcos, d, w)
    if (jst <= 1) then
        q(:m, j) = b(:m)
    else
        if (jp2 > n) goto 177
175 continue
    q(:m, j) = HALF * (q(:m, j)-q(:m, jm1)-q(:m, jp1)) + b(:m)
    cycle
177 continue
    select case (irreg)
        case (1)
            goto 175
        case (2)
            goto 178
    end select
178 continue
    if (j + jsh <= n) then
        q(:m, j) = b(:m) + p(iip+1:m+iip)
        iip = iip - m
    else
        q(:m, j) = b(:m) + q(:m, j) - q(:m, jm1)
    end if
end if
end do
l = l/2
goto 164
183 continue
    w(1) = cmplx(real(ipstor, kind=wp), ZERO, kind=wp)

end subroutine solve_poisson_dirichlet

subroutine solve_poisson_neumann(m, n, istag, mixbnd, a, bb, c, q, idimq, b, b2, &
    b3, w, w2, w3, d, tcos, p)
    !
    ! Purpose:
    !
    !     subroutine to solve poisson's equation with neumann boundary
    !     conditions.
    !
    !     istag = 1 if the last diagonal block is a.
    !     istag = 2 if the last diagonal block is a-i.
    !     mixbnd = 1 if have neumann boundary conditions at both boundaries.
    !     mixbnd = 2 if have neumann boundary conditions at bottom and
    !     dirichlet condition at top.  (for this case, must have istag = 1.)
    !

    ! Dummy arguments

    integer(ip), intent(in) :: m
    integer(ip), intent(in) :: n
    integer(ip), intent(in) :: istag
    integer(ip), intent(in) :: mixbnd
    integer(ip), intent(in) :: idimq
    complex(wp) :: a(m)
    complex(wp) :: bb(m)
    complex(wp) :: c(m)
    complex(wp), intent(inout) :: q(idimq,n)
    complex(wp) :: b(m)
    complex(wp) :: b2(m)
    complex(wp) :: b3(m)
    complex(wp) :: w(m)
    complex(wp) :: w2(m)
    complex(wp) :: w3(m)
    complex(wp) :: d(m)
    complex(wp) :: tcos(m)
    complex(wp), intent(inout) :: p(n*4)

    ! Local variables

    integer(ip) :: k(4)
    integer(ip) :: mr, iip
    integer(ip) :: ipstor, i2r, jr, nr, nlast, kr
    integer(ip) :: lr, i, nrod, jstart, jstop, i2rby2, j, jp1, jp2, jp3, jm1
    integer(ip) :: jm2, jm3, nrodpr, ii, i1, i2, jr2, nlastp, jstep
    real(wp)    :: fistag, fnum, fden
    complex(wp) :: fi, t

    associate( &
        k1 => k(1), &
        k2 => k(2), &
        k3 => k(3), &
        k4 => k(4) &
        )

        fistag = 3 - istag
        fnum = ONE/istag
        fden = HALF * real(istag - 1, kind=wp)
        mr = m
        iip = -mr
        ipstor = 0
        i2r = 1
        jr = 2
        nr = n
        nlast = n
        kr = 1
        lr = 0
        select case (istag)
            case (1)
                goto 101
            case (2)
                goto 103
        end select
101 continue
    q(:mr, n) = HALF * q(:mr, n)
    select case (mixbnd)
        case (1)
            goto 103
        case (2)
            goto 104
    end select
103 continue
    if (n <= 3) goto 155
104 continue
    jr = 2*i2r
    nrod = 1
    if ((nr/2)*2 == nr) nrod = 0
    select case (mixbnd)
        case default
            jstart = 1
        case (2)
            jstart = jr
            nrod = 1 - nrod
    end select

    jstop = nlast - jr
    if (nrod == 0) jstop = jstop - i2r
    call generate_cosines(i2r, 1, HALF, ZERO, tcos)
    i2rby2 = i2r/2
    if (jstop < jstart) then
        j = jr
    else
        do j = jstart, jstop, jr
            jp1 = j + i2rby2
            jp2 = j + i2r
            jp3 = jp2 + i2rby2
            jm1 = j - i2rby2
            jm2 = j - i2r
            jm3 = jm2 - i2rby2
            if (j == 1) then
                jm1 = jp1
                jm2 = jp2
                jm3 = jp3
            end if
            if (i2r == 1) then
                if (j == 1) jm2 = jp2
                b(:mr) = TWO * q(:mr, j)
                q(:mr, j) = q(:mr, jm2) + q(:mr, jp2)
            else
                do i = 1, mr
                    fi = q(i, j)
                    q(i, j)=q(i, j)-q(i, jm1)-q(i, jp1)+q(i, jm2)+q(i, jp2)
                    b(i) = fi + q(i, j) - q(i, jm3) - q(i, jp3)
                end do
            end if
            call solve_linear_system(i2r, 0, mr, a, bb, c, b, tcos, d, w)
            q(:mr, j) = q(:mr, j) + b(:mr)
        !
        !     end of reduction for regular unknowns.
        !
        end do
        !
        !     begin special reduction for last unknown.
        !
        j = jstop + jr
    end if
    nlast = j
    jm1 = j - i2rby2
    jm2 = j - i2r
    jm3 = jm2 - i2rby2
    if (nrod /= 0) then
        !
        !     odd number of unknowns
        !
        if (i2r == 1) then
            b(:mr) = fistag*q(:mr, j)
            q(:mr, j) = q(:mr, jm2)
        else
            b(:mr) = q(:mr, j) + HALF * (q(:mr, jm2)-q(:mr, jm1)-q(:mr, jm3))
            if (nrodpr == 0) then
                q(:mr, j) = q(:mr, jm2) + p(iip+1:mr+iip)
                iip = iip - mr
            else
                q(:mr, j) = q(:mr, j) - q(:mr, jm1) + q(:mr, jm2)
            end if
            if (lr /= 0) then
                call generate_cosines(lr, 1, HALF, fden, tcos(kr+1))
            else
                b(:mr) = fistag*b(:mr)
            end if
        end if
        call generate_cosines(kr, 1, HALF, fden, tcos)
        call solve_linear_system(kr, lr, mr, a, bb, c, b, tcos, d, w)
        q(:mr, j) = q(:mr, j) + b(:mr)
        kr = kr + i2r
    else
        jp1 = j + i2rby2
        jp2 = j + i2r
        if (i2r == 1) then
            b(:mr) = q(:mr, j)
            call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
            iip = 0
            ipstor = mr
            select case (istag)
                case default
                    p(:mr) = b(:mr)
                    b(:mr) = b(:mr) + q(:mr, n)
                    tcos(1) = cmplx(ONE, ZERO, kind=wp)
                    tcos(2) = ZERO
                    call solve_linear_system(1, 1, mr, a, bb, c, b, tcos, d, w)
                    q(:mr, j) = q(:mr, jm2) + p(:mr) + b(:mr)
                    goto 150
                case (1)
                    p(:mr) = b(:mr)
                    q(:mr, j) = q(:mr, jm2) + TWO * q(:mr, jp2) + THREE*b(:mr)
                    goto 150
            end select
        end if
        b(:mr) = q(:mr, j) + HALF * (q(:mr, jm2)-q(:mr, jm1)-q(:mr, jm3))
        if (nrodpr == 0) then
            b(:mr) = b(:mr) + p(iip+1:mr+iip)
        else
            b(:mr) = b(:mr) + q(:mr, jp2) - q(:mr, jp1)
        end if
        call solve_linear_system(i2r, 0, mr, a, bb, c, b, tcos, d, w)
        iip = iip + mr
        ipstor = max(ipstor, iip + mr)
        p(iip+1:mr+iip) = b(:mr) + HALF * (q(:mr, j)-q(:mr, jm1)-q(:mr, jp1))
        b(:mr) = p(iip+1:mr+iip) + q(:mr, jp2)
        if (lr /= 0) then
            call generate_cosines(lr, 1, HALF, fden, tcos(i2r+1))
            call merge_tcos(tcos, 0, i2r, i2r, lr, kr)
        else
            do i = 1, i2r
                ii = kr + i
                tcos(ii) = tcos(i)
            end do
        end if
        call generate_cosines(kr, 1, HALF, fden, tcos)
        if (lr == 0) then
            select case (istag)
                case (1)
                    goto 146
                case (2)
                    goto 145
            end select
        end if
145 continue
    call solve_linear_system(kr, kr, mr, a, bb, c, b, tcos, d, w)
    goto 148
146 continue
    b(:mr) = fistag*b(:mr)
148 continue
    q(:mr, j) = q(:mr, jm2) + p(iip+1:mr+iip) + b(:mr)
150 continue
    lr = kr
    kr = kr + jr
end if
select case (mixbnd)
    case default
        nr = (nlast - 1)/jr + 1
        if (nr <= 3) goto 155
    case (2)
        nr = nlast/jr
        if (nr <= 1) goto 192
end select

i2r = jr
nrodpr = nrod
goto 104
155 continue
    j = 1 + jr
    jm1 = j - i2r
    jp1 = j + i2r
    jm2 = nlast - i2r
    if (nr /= 2) then
        if (lr /= 0) goto 170
        if (n == 3) then
            !
            !     case n = 3.
            !
            select case (istag)
                case (1)
                    goto 156
                case (2)
                    goto 168
            end select
156     continue
        b(:mr) = q(:mr, 2)
        tcos(1) = ZERO
        call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
        q(:mr, 2) = b(:mr)
        b(:mr) = FOUR*b(:mr) + q(:mr, 1) + TWO * q(:mr, 3)
        tcos(1) = cmplx(-TWO, ZERO, kind=wp)
        tcos(2) = cmplx(TWO, ZERO, kind=wp)
        i1 = 2
        i2 = 0
        call solve_linear_system(i1, i2, mr, a, bb, c, b, tcos, d, w)
        q(:mr, 2) = q(:mr, 2) + b(:mr)
        b(:mr) = q(:mr, 1) + TWO * q(:mr, 2)
        tcos(1) = ZERO
        call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
        q(:mr, 1) = b(:mr)
        jr = 1
        i2r = 0
        goto 194
    end if
    !
    !     case n = 2**p+1
    !
    select case (istag)
        case (1)
            goto 162
        case (2)
            goto 170
    end select
162 continue
    b(:mr) = q(:mr, j) + HALF * q(:mr, 1) - q(:mr, jm1) + q(:mr, nlast) - &
        q(:mr, jm2)
    call generate_cosines(jr, 1, HALF, ZERO, tcos)
    call solve_linear_system(jr, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, j) = HALF * (q(:mr, j)-q(:mr, jm1)-q(:mr, jp1)) + b(:mr)
    b(:mr) = q(:mr, 1) + TWO * q(:mr, nlast) + FOUR*q(:mr, j)
    jr2 = 2*jr
    call generate_cosines(jr, 1, ZERO, ZERO, tcos)
    tcos(jr+1:jr*2) = -tcos(jr:1:(-1))
    call solve_linear_system(jr2, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, j) = q(:mr, j) + b(:mr)
    b(:mr) = q(:mr, 1) + TWO * q(:mr, j)
    call generate_cosines(jr, 1, HALF, ZERO, tcos)
    call solve_linear_system(jr, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, 1) = HALF * q(:mr, 1) - q(:mr, jm1) + b(:mr)
    goto 194
!
!     case of general n with nr = 3 .
!
168 continue
    b(:mr) = q(:mr, 2)
    q(:mr, 2) = ZERO
    b2(:mr) = q(:mr, 3)
    b3(:mr) = q(:mr, 1)
    jr = 1
    i2r = 0
    j = 2
    goto 177
170 continue
    b(:mr) = HALF * q(:mr, 1) - q(:mr, jm1) + q(:mr, j)
    if (nrod == 0) then
        b(:mr) = b(:mr) + p(iip+1:mr+iip)
    else
        b(:mr) = b(:mr) + q(:mr, nlast) - q(:mr, jm2)
    end if
    do i = 1, mr
        t = HALF * (q(i, j)-q(i, jm1)-q(i, jp1))
        q(i, j) = t
        b2(i) = q(i, nlast) + t
        b3(i) = q(i, 1) + TWO * t
    end do
177 continue
    k1 = kr + 2*jr - 1
    k2 = kr + jr
    tcos(k1+1) = cmplx(-TWO, ZERO, kind=wp)
    k4 = k1 + 3 - istag
    call generate_cosines(k2 + istag - 2, 1, ZERO, fnum, tcos(k4))
    k4 = k1 + k2 + 1
    call generate_cosines(jr - 1, 1, ZERO, ONE, tcos(k4))
    call merge_tcos(tcos, k1, k2, k1 + k2, jr - 1, 0)
    k3 = k1 + k2 + lr
    call generate_cosines(jr, 1, HALF, ZERO, tcos(k3+1))
    k4 = k3 + jr + 1
    call generate_cosines(kr, 1, HALF, fden, tcos(k4))
    call merge_tcos(tcos, k3, jr, k3 + jr, kr, k1)
    if (lr /= 0) then
        call generate_cosines(lr, 1, HALF, fden, tcos(k4))
        call merge_tcos(tcos, k3, jr, k3 + jr, lr, k3 - lr)
        call generate_cosines(kr, 1, HALF, fden, tcos(k4))
    end if
    k3 = kr
    k4 = kr
    call solve_tridiagonal_system(mr, a, bb, c, k, b, b2, b3, tcos, d, w, w2, w3)
    b(:mr) = b(:mr) + b2(:mr) + b3(:mr)
    tcos(1) = cmplx(TWO, ZERO, kind=wp)
    call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, j) = q(:mr, j) + b(:mr)
    b(:mr) = q(:mr, 1) + TWO * q(:mr, j)
    call generate_cosines(jr, 1, HALF, ZERO, tcos)
    call solve_linear_system(jr, 0, mr, a, bb, c, b, tcos, d, w)
    if (jr == 1) then
        q(:mr, 1) = b(:mr)
        goto 194
    end if
    q(:mr, 1) = HALF * q(:mr, 1) - q(:mr, jm1) + b(:mr)
    goto 194
end if
if (n == 2) then
    !
    !     case  n = 2
    !
    b(:mr) = q(:mr, 1)
    tcos(1) = ZERO
    call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, 1) = b(:mr)
    b(:mr) = TWO * (q(:mr, 2)+b(:mr))*fistag
    tcos(1) = cmplx((-fistag), ZERO, kind=wp)
    tcos(2) = cmplx(TWO, ZERO, kind=wp)
    call solve_linear_system(2, 0, mr, a, bb, c, b, tcos, d, w)
    q(:mr, 1) = q(:mr, 1) + b(:mr)
    jr = 1
    i2r = 0
    goto 194
end if
b3(:mr) = ZERO
b(:mr) = q(:mr, 1) + TWO * p(iip+1:mr+iip)
q(:mr, 1) = HALF * q(:mr, 1) - q(:mr, jm1)
b2(:mr) = TWO * (q(:mr, 1)+q(:mr, nlast))
k1 = kr + jr - 1
tcos(k1+1) = cmplx(-TWO, ZERO, kind=wp)
k4 = k1 + 3 - istag
call generate_cosines(kr + istag - 2, 1, ZERO, fnum, tcos(k4))
k4 = k1 + kr + 1
call generate_cosines(jr - 1, 1, ZERO, ONE, tcos(k4))
call merge_tcos(tcos, k1, kr, k1 + kr, jr - 1, 0)
call generate_cosines(kr, 1, HALF, fden, tcos(k1+1))
k2 = kr
k4 = k1 + k2 + 1
call generate_cosines(lr, 1, HALF, fden, tcos(k4))
k3 = lr
k4 = 0
call solve_tridiagonal_system(mr, a, bb, c, k, b, b2, b3, tcos, d, w, w2, w3)
b(:mr) = b(:mr) + b2(:mr)
tcos(1) = cmplx(TWO, ZERO, kind=wp)
call solve_linear_system(1, 0, mr, a, bb, c, b, tcos, d, w)
q(:mr, 1) = q(:mr, 1) + b(:mr)
goto 194
192 continue
    b(:mr) = q(:mr, nlast)
    goto 196
194 continue
    j = nlast - jr
    b(:mr) = q(:mr, nlast) + q(:mr, j)
196 continue
    jm2 = nlast - i2r
    if (jr == 1) then
        q(:mr, nlast) = ZERO
    else
        if (nrod == 0) then
            q(:mr, nlast) = p(iip+1:mr+iip)
            iip = iip - mr
        else
            q(:mr, nlast) = q(:mr, nlast) - q(:mr, jm2)
        end if
    end if
    call generate_cosines(kr, 1, HALF, fden, tcos)
    call generate_cosines(lr, 1, HALF, fden, tcos(kr+1))
    if (lr == 0) then
        b(:mr) = fistag*b(:mr)
    end if
    call solve_linear_system(kr, lr, mr, a, bb, c, b, tcos, d, w)
    q(:mr, nlast) = q(:mr, nlast) + b(:mr)
    nlastp = nlast
206 continue
    jstep = jr
    jr = i2r
    i2r = i2r/2
    if (jr == 0) goto 222
    select case (mixbnd)
        case default
            jstart = 1 + jr
        case (2)
            jstart = jr
    end select

    kr = kr - jr
    if (nlast + jr <= n) then
        kr = kr - jr
        nlast = nlast + jr
        jstop = nlast - jstep
    else
        jstop = nlast - jr
    end if
    lr = kr - jr
    call generate_cosines(jr, 1, HALF, ZERO, tcos)
    do j = jstart, jstop, jstep
        jm2 = j - jr
        jp2 = j + jr
        if (j == jr) then
            b(:mr) = q(:mr, j) + q(:mr, jp2)
        else
            b(:mr) = q(:mr, j) + q(:mr, jm2) + q(:mr, jp2)
        end if
        if (jr == 1) then
            q(:mr, j) = ZERO
        else
            jm1 = j - i2r
            jp1 = j + i2r
            q(:mr, j) = HALF * (q(:mr, j)-q(:mr, jm1)-q(:mr, jp1))
        end if
        call solve_linear_system(jr, 0, mr, a, bb, c, b, tcos, d, w)
        q(:mr, j) = q(:mr, j) + b(:mr)
    end do
    nrod = 1
    if (nlast + i2r <= n) nrod = 0
    if (nlastp /= nlast) goto 194
    goto 206
222 continue
    w(1) = cmplx(real(ipstor, kind=wp), ZERO, kind=wp)

end associate

end subroutine solve_poisson_neumann

! Purpose:
!
! To solve poisson equation with periodic boundary conditions.
!
subroutine solve_poisson_periodic(m, n, a, bb, c, q, idimq, b, b2, b3, w, w2, w3, d, tcos, p)

    ! Dummy arguments
    integer(ip), intent(in) :: m
    integer(ip), intent(in) :: n
    integer(ip), intent(in) :: idimq
    complex(wp) :: a(*)
    complex(wp) :: bb(*)
    complex(wp) :: c(*)
    complex(wp) :: q(idimq,n)
    complex(wp) :: b(*)
    complex(wp) :: b2(*)
    complex(wp) :: b3(*)
    complex(wp) :: w(*)
    complex(wp) :: w2(*)
    complex(wp) :: w3(*)
    complex(wp) :: d(*)
    complex(wp) :: tcos(*)
    complex(wp) :: p(n*4)

    ! Local variables
    integer(ip) :: mr, nr, nrm1, j, nrmj, nrpj, i, lh
    real(wp)    :: ipstor
    complex(wp) :: s, t

    mr = m
    nr = (n + 1)/2
    nrm1 = nr - 1

    if ((2*nr) == n) then
        !
        !     even number of unknowns
        !
        do j = 1, nrm1
            nrmj = nr - j
            nrpj = nr + j
            do i = 1, mr
                s = q(i, nrmj) - q(i, nrpj)
                t = q(i, nrmj) + q(i, nrpj)
                q(i, nrmj) = s
                q(i, nrpj) = t
            end do
        end do

        q(:mr, nr) = TWO * q(:mr, nr)
        q(:mr, n) = TWO * q(:mr, n)

        call solve_poisson_dirichlet (mr, nrm1, 1, a, bb, c, q, idimq, b, w, d, tcos, p)

        ipstor = real(w(1), kind=wp)

        call solve_poisson_neumann(mr, nr + 1, 1, 1, a, bb, c, q(1, nr), idimq, b, b2, &
            b3, w, w2, w3, d, tcos, p)

        ipstor = max(ipstor, real(w(1), kind=wp))

        do j = 1, nrm1
            nrmj = nr - j
            nrpj = nr + j
            do i = 1, mr
                s = HALF * (q(i, nrpj)+q(i, nrmj))
                t = HALF * (q(i, nrpj)-q(i, nrmj))
                q(i, nrmj) = s
                q(i, nrpj) = t
            end do
        end do

        q(:mr, nr) = HALF * q(:mr, nr)
        q(:mr, n) = HALF * q(:mr, n)

    else

        do j = 1, nrm1
            nrpj = n + 1 - j
            do i = 1, mr
                s = q(i, j) - q(i, nrpj)
                t = q(i, j) + q(i, nrpj)
                q(i, j) = s
                q(i, nrpj) = t
            end do
        end do

        q(:mr, nr) = TWO * q(:mr, nr)
        lh = nrm1/2

        do j = 1, lh
            nrmj = nr - j
            do i = 1, mr
                s = q(i, j)
                q(i, j) = q(i, nrmj)
                q(i, nrmj) = s
            end do
        end do

        call solve_poisson_dirichlet(mr, nrm1, 2, a, bb, c, q, idimq, b, w, d, tcos, p)

        ipstor = real(w(1), kind=wp)

        call solve_poisson_neumann(mr, nr, 2, 1, a, bb, c, q(1, nr), idimq, b, b2, b3, &
            w, w2, w3, d, tcos, p)

        ipstor = max(ipstor, real(w(1), kind=wp))

        do j = 1, nrm1
            nrpj = nr + j
            do i = 1, mr
                s = HALF * (q(i, nrpj)+q(i, j))
                t = HALF * (q(i, nrpj)-q(i, j))
                q(i, nrpj) = t
                q(i, j) = s
            end do
        end do

        q(:mr, nr) = HALF * q(:mr, nr)

        do j = 1, lh
            nrmj = nr - j
            do i = 1, mr
                s = q(i, j)
                q(i, j) = q(i, nrmj)
                q(i, nrmj) = s
            end do
        end do
    end if

    w(1) = cmplx(ipstor, ZERO, kind=wp)

end subroutine solve_poisson_periodic

! Purpose:
!
! Computes required cosine values in ascending
! order. When ijump > 1 the routine computes values
!
! 2*cos(j*pi/l) , j=1, 2, ..., l and j /= 0(mod n/ijump+1)
!
! where l = ijump*(n/ijump+1).
!
!
! when ijump = 1 it computes
!
! 2*cos((j-fnum)*pi/(n+fden)) ,  j=1, 2, ... , n
!
! where
!
!        fnum = 0.5, fden = 0.0, for regular reduction values
!        fnum = 0.0, fden = 1.0, for b-r and c-r when istag = 1
!        fnum = 0.0, fden = 0.5, for b-r and c-r when istag = 2
!        fnum = 0.5, fden = 0.5, for b-r and c-r when istag = 2
!                                in solve_poisson_neumann only.
!
!
pure subroutine generate_cosines(n, ijump, fnum, fden, a)

    ! Dummy arguments
    integer(ip), intent(in)  :: n
    integer(ip), intent(in)  :: ijump
    real(wp),    intent(in)  :: fnum
    real(wp),    intent(in)  :: fden
    complex(wp), intent(out) :: a(*)

    ! Local variables
    integer(ip)         :: k3, k4, k, k1, k5, i, k2, np1
    real(wp)            :: pibyn, x, y

    if (n /= 0) then
        if (ijump /= 1) then
            k3 = n/ijump + 1
            k4 = k3 - 1
            pibyn = PI/(n + ijump)
            do k = 1, ijump
                k1 = (k - 1)*k3
                k5 = (k - 1)*k4
                do i = 1, k4
                    x = k1 + i
                    k2 = k5 + i
                    a(k2) = cmplx((-TWO * cos(x*pibyn)), ZERO, kind=wp)
                end do
            end do
        else
            np1 = n + 1
            y = PI/(real(n, kind=wp) + fden)
            do i = 1, n
                x = real(np1 - i, kind=wp) - fnum
                a(i) = cmplx(TWO * cos(x*y), ZERO, kind=wp)
            end do
        end if
    end if

end subroutine generate_cosines

! Purpose:
!
! Merges two ascending strings of numbers in the
! array tcos.  The first string is of length m1 and starts at
! tcos(i1+1).  The second string is of length m2 and starts at
! tcos(i2+1).  The merged string goes into tcos(i3+1).
!
subroutine merge_tcos(tcos, i1, m1, i2, m2, i3)

    ! Dummy arguments
    integer(ip), intent(in)     :: i1
    integer(ip), intent(in)     :: m1
    integer(ip), intent(in)     :: i2
    integer(ip), intent(in)     :: m2
    integer(ip), intent(in)     :: i3
    complex(wp), intent(inout) :: tcos(*)

    ! Local variables
    integer(ip) :: j11, j3, j1, j2, j, l, k, m
    complex(wp) :: x, y

    j1 = 1
    j2 = 1
    j = i3

    if_construct: if (m1 /= 0) then
        if (m2 /= 0) then
            outer_loop: do
                j11 = j1
                j3 = max(m1, j11)
                block_construct: block
                    do j1 = j11, j3
                        j = j + 1
                        l = j1 + i1
                        x = tcos(l)
                        l = j2 + i2
                        y = tcos(l)
                        if (real(x - y, kind=wp) > ZERO) exit block_construct
                        tcos(j) = x
                    end do
                    if (j2 > m2) return
                    exit if_construct
                end block block_construct
                tcos(j) = y
                j2 = j2 + 1
                if (j2 > m2) exit outer_loop
            end do outer_loop
            if (j1 > m1) return
        end if
        k = j - j1 + 1
        do j = j1, m1
            m = k + j
            l = j + i1
            tcos(m) = tcos(l)
        end do
        return
    end if if_construct

    k = j - j2 + 1

    do j = j2, m2
        m = k + j
        l = j + i2
        tcos(m) = tcos(l)
    end do

end subroutine merge_tcos

! Purpose:
!
! To solve a system of linear equations where the
! coefficient matrix is a rational function in the matrix given by
! tridiagonal  ( . . . , a(i), b(i), c(i), . . . ).
!
subroutine solve_linear_system(idegbr, idegcr, m, a, b, c, y, tcos, d, w)

    ! Dummy arguments
    integer(ip), intent(in)     :: idegbr
    integer(ip), intent(in)     :: idegcr
    integer(ip), intent(in)     :: m
    complex(wp), intent(in)     :: a(m)
    complex(wp), intent(in)     :: b(m)
    complex(wp), intent(in)     :: c(m)
    complex(wp), intent(inout) :: y(m)
    complex(wp), intent(in)     :: tcos(*)
    complex(wp), intent(out)    :: d(m)
    complex(wp), intent(out)    :: w(m)

    ! Local variables
    integer(ip) :: mm1, ifb, ifc, l, lint, k, i, iip
    complex(wp) :: x, xx, z

    mm1 = m - 1
    ifb = idegbr + 1
    ifc = idegcr + 1
    l = ifb/ifc
    lint = 1

    do k = 1, idegbr
        x = tcos(k)

        if (k == l) then
            i = idegbr + lint
            xx = x - tcos(i)
            w = y
            y = xx*y
        end if

        z = ONE/(b(1)-x)
        d(1) = c(1)*z
        y(1) = y(1)*z

        do i = 2, mm1
            z = ONE/(b(i)-x-a(i)*d(i-1))
            d(i) = c(i)*z
            y(i) = (y(i)-a(i)*y(i-1))*z
        end do

        z = b(m) - x - a(m)*d(mm1)

        if (abs(z) == ZERO) then
            y(m) = ZERO
        else
            y(m) = (y(m)-a(m)*y(mm1))/z
        end if

        do iip = 1, mm1
            y(m-iip) = y(m-iip) - d(m-iip)*y(m+1-iip)
        end do

        if (k /= l) cycle

        y = y + w
        lint = lint + 1
        l = (lint*ifb)/ifc
    end do

end subroutine solve_linear_system

subroutine solve_tridiagonal_system(m, a, b, c, k, y1, y2, y3, tcos, d, w1, w2, w3)

    ! Dummy arguments
    integer(ip), intent(in)     :: m
    integer(ip), intent(in)     :: k(4)
    complex(wp), intent(in)     :: a(m)
    complex(wp), intent(in)     :: b(m)
    complex(wp), intent(in)     :: c(m)
    complex(wp), intent(inout) :: y1(m)
    complex(wp), intent(inout) :: y2(m)
    complex(wp), intent(inout) :: y3(m)
    complex(wp), intent(in)     :: tcos(*)
    complex(wp), intent(out)    :: d(m)
    complex(wp), intent(out)    :: w1(m)
    complex(wp), intent(out)    :: w2(m)
    complex(wp), intent(out)    :: w3(m)

    ! Local variables
    integer(ip) :: mm1, k1, k2, k3, k4
    integer(ip) :: if1, if2, if3, if4, k2k3k4, l1, l2
    integer(ip) :: l3, lint1, lint2, lint3
    integer(ip) :: kint1, kint2, kint3, n, i, iip
    complex(wp) :: x, xx, z

    mm1 = m - 1
    k1 = k(1)
    k2 = k(2)
    k3 = k(3)
    k4 = k(4)
    if1 = k1 + 1
    if2 = k2 + 1
    if3 = k3 + 1
    if4 = k4 + 1
    k2k3k4 = k2 + k3 + k4

    if (k2k3k4 /= 0) then
        l1 = if1/if2
        l2 = if1/if3
        l3 = if1/if4
        lint1 = 1
        lint2 = 1
        lint3 = 1
        kint1 = k1
        kint2 = kint1 + k2
        kint3 = kint2 + k3
    end if

    do n = 1, k1
        x = tcos(n)

        if (k2k3k4 /= 0) then
            if (n == l1) w1 = y1
            if (n == l2) w2 = y2
            if (n == l3) w3 = y3
        end if

        z = ONE/(b(1)-x)
        d(1) = c(1)*z
        y1(1) = y1(1)*z
        y2(1) = y2(1)*z
        y3(1) = y3(1)*z

        do i = 2, m
            z = ONE/(b(i)-x-a(i)*d(i-1))
            d(i) = c(i)*z
            y1(i) = (y1(i)-a(i)*y1(i-1))*z
            y2(i) = (y2(i)-a(i)*y2(i-1))*z
            y3(i) = (y3(i)-a(i)*y3(i-1))*z
        end do

        do iip = 1, mm1
            y1(m-iip) = y1(m-iip) - d(m-iip)*y1(m+1-iip)
            y2(m-iip) = y2(m-iip) - d(m-iip)*y2(m+1-iip)
            y3(m-iip) = y3(m-iip) - d(m-iip)*y3(m+1-iip)
        end do

        if (k2k3k4 == 0) cycle

        if (n == l1) then
            i = lint1 + kint1
            xx = x - tcos(i)
            y1 = xx*y1 + w1
            lint1 = lint1 + 1
            l1 = (lint1*if1)/if2
        end if

        if (n == l2) then
            i = lint2 + kint2
            xx = x - tcos(i)
            y2 = xx*y2 + w2
            lint2 = lint2 + 1
            l2 = (lint2*if1)/if3
        end if

        if (n /= l3) cycle

        i = lint3 + kint3
        xx = x - tcos(i)
        y3 = xx*y3 + w3
        lint3 = lint3 + 1
        l3 = (lint3*if1)/if4
    end do

end subroutine solve_tridiagonal_system

end module complex_linear_systems_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! May       2016    Fortran 2008 changes
!


program nr_test

  use healpix_types
  use pix_tools
  use alm_tools
  use fitstools, only: getsize_fits, input_map
  use, intrinsic :: iso_c_binding

  implicit none
  include 'fftw3.f03'

  integer :: npixtot, nmaps, nside, npix
  double precision, dimension(:, :), allocatable :: map
  integer :: err_map, err_dw8, err_alm

  integer :: lmax = 512
  double precision, dimension(2) :: z
  double precision, dimension(:, :), allocatable :: dw8
  complex, dimension(:, :, :), allocatable :: alm

  npixtot = getsize_fits("../../planck_data/COM_CMB_IQU-smica_1024_R2.02_full.fits", nmaps=nmaps, nside=nside)
  npix = nside2npix(nside)

  write(unit=*, fmt=*) 'npixtot', npixtot
  write(unit=*, fmt=*) 'npix', npix

  nmaps = 1

  allocate(map(0:npix-1,1:nmaps), stat=err_map)
  if (err_map /= 0) print *, "map(0:npix-1,1:nmaps): Allocation request denied"

  allocate(dw8(1:2*nside,1:3), stat=err_dw8)
  if (err_dw8 /= 0) print *, "dw8(1:2*nside,1:3): Allocation request denied"

  allocate(alm(1:nmaps, 0:lmax, 0:lmax), stat=err_alm)
  if (err_alm /= 0) print *, "alm(1:3, 0:lmax, 0:lmax): Allocation request denied"

  dw8 = 1.d0

  z = dsin(10.d0 * DEG2RAD)

  call input_map("../../planck_data/COM_CMB_IQU-smica_1024_R2.02_full.fits", map, npix, nmaps, fmissval=0.d0)

  call map2alm(nside, lmax, lmax, map, alm)

  write(unit=*, fmt=*) 'nmaps', nmaps
  write(unit=*, fmt=*) 'nside', nside
  write(unit=*, fmt=*) 'npix-1', npix-1
  write(unit=*, fmt=*) 'npixtot', npixtot
  write(unit=*, fmt=*) '12*nsmax**2-1', nside2npix(nside)-1

  if (allocated(alm)) deallocate(alm, stat=err_alm)
  if (err_alm /= 0) print *, "alm(1:3, 0:lmax, 0:lmax): Deallocation request denied"

  if (allocated(dw8)) deallocate(dw8, stat=err_dw8)
  if (err_dw8 /= 0) print *, "dw8(1:2*nside,1:3): Deallocation request denied"

  if (allocated(map)) deallocate(map, stat=err_map)
  if (err_map /= 0) print *, "map: Deallocation request denied"

end program nr_test


SUBROUTINE phasefield_setprob()
    IMPLICIT none

    INTEGER example
    COMMON /comm_example/ example

    DOUBLE PRECISION S, alpha, m, xi, k, gamma
    COMMON /comm_parms/ S, alpha, m, xi, k, gamma

    DOUBLE PRECISION r0, x0, y0
    COMMON /comm_init/ r0, x0, y0

    INTEGER bc_type(0:3)
    COMMON /comm_bc/ bc_type

    DOUBLE PRECISION pi,pi2
    COMMON /compi/ pi, pi2

    integer i

    pi = 4.d0*atan(1.d0)
    pi2 = 2*pi

    open(10,file='setprob.data')
    read(10,*) example
    read(10,*) S
    read(10,*) alpha
    read(10,*) m
    read(10,*) xi
    read(10,*) k
    read(10,*) gamma
    read(10,*) r0
    read(10,*) x0
    read(10,*) y0

    read(10,*) bc_type(0)
    read(10,*) bc_type(1)
    read(10,*) bc_type(2)
    read(10,*) bc_type(3)
    close(10)

end subroutine phasefield_setprob


program i
  real ::b=10.0
  real  ::c=4.0
  real ::a
  a = 3.0 * (b * c + (5**1) )
  b = 20.0
end program i


c>>   1995-05-28  DRGSORTP  Krogh   Converted SFTRAN to Fortran
c>>   1988-11-22  DRGSORTP  Snyder  Initial code.
c
c     Test driver for GSORTP.
c
c     Construct an array of 1000 random numbers using SRANUA.
c     Sort it using GSORTP.
c     Check whether it is in order.
c
      logical OK
      integer I, COMPAR, P(1:1000)
      external COMPAR
      real R(1:1000)
      common /RCOM/ R
c
c     Generate 1000 random numbers
      call sranua (r, 1000)
c     Sort them using GSORTP.
      ok=.TRUE.
      call gsortp (compar,1000,p)
c     Check the order.
      do 10 i = 2, 1000
         if (r(p(i)).lt.r(p(i-1))) ok=.FALSE.
10    continue
c     Print the results.
      if(ok)then
         print *,'GSORTP succeeded'
      else
         print *,'GSORTP failed'
      end if
c
      end
      integer function COMPAR(I,J)
c
c     Determine the relative order of R(I) and R(J), where R is in
c     the common block /RCOM/.  Return -1 if R(I) should preceed R(J)
c     in the sorted order, +1 if R(I) should follow R(J), and 0
c     otherwise.
c
      integer I,J
      real R(1:1000)
      common /RCOM/ R
      if (R(I)-R(J)) 10,20,30
10    compar=-1
      return
20    compar=0
      return
30    compar=+1
      return
c
      end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program zieee14
use ieee_arithmetic
real*4 a,b,c,c2
real*8 x,y,z,z2
logical lexp(4), lres(4)

a = sqrt(5.0)
x = sqrt(5.0d0)

b = exp(1.0) / 2.0
y = exp(1.0d0) / 2.0d0

c = ieee_rem(a,b)
z = ieee_rem(x,y)

c2 = a - b*2.0
z2 = x - y*2.0d0

lres(1) = (abs(c2 - c) .lt. 0.00001)
lres(2) = (abs(z2 - z) .lt. 0.000000001d0)
z = ieee_rem(a,y)
lres(3) = (abs(z2 - z) .lt. 0.00001d0)
z = ieee_rem(x,b)
lres(4) = (abs(z2 - z) .lt. 0.00001d0)

lexp = .true.
call check(lres, lexp, 4)

end