!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-422                                                         *
!    (C) COPYRIGHT IBM CORP. 1995, 1996. ALL RIGHTS RESERVED.         *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
      module northsouth
!
!
!
        use pdata
        implicit none
!
!     everything private by default
!
      private
      public :: dsendnorth,drcvsouth,dsendsouth,drcvnorth
      public :: csendnorth,crcvsouth,csendsouth,crcvnorth
      public :: ssendnorth,srcvsouth,ssendsouth,srcvnorth
      public :: zsendnorth,zrcvsouth,zsendsouth,zrcvnorth

!
! private data to be used with the intenal routines
!
      integer :: number_of_rows, block
      integer :: north_proc, south_proc, number_of_blocks
      integer :: prow_owning_last_block, last_block, start_block,end_block

!  source code for the generic routines:
!     sendnorthborder, sendsouthborder, rcvnorthborder, rcvsouthborder
!
!
!  This module contains routines to send and receive the upper and lower
!  most rows of each local block to the processor logically directly above
!  or below the current process. The routines are broken into sends and
!  receives. For example if we have the global matrix on a 2x2 processor
!  grid given below
!
!               GLOBAL matrix
!  |------------------------------------------------------------|
!  |       [A1]       |   [A2]      |   [A3]      |   [A4]      |
!  |     block 0,0    | block 0,1   | block 0,2   | block 0,3   |
!  |      on 0, 0     |  on 0,1     |  on 0,0     |  on 0,1     |
!  |------------------|-------------|-------------|-------------|
!  |       [B1]       |   [B2]      |   [B3]      |   [B4]      |
!  |     block 1,0    | block 1,1   | block 1,2   | block 1,3   |
!  |      on 1,0      |  on 1,1     |  on 1,0     |  on 1,1     |
!  |------------------|-------------|-------------|-------------|
!  |       [C1]       |   [C2]      |   [C3]      |   [C4]      |
!  |     block 2, 0   | block 2,1   | block 2,2   | block 2,3   |
!  |     on 0, 0      |  on 0,1     |  on 0,0     |  on 0,1     |
!  |------------------|-------------|-------------|-------------|
!  |       [D1]       |   [D2]      |   [D3]      |   [D4]      |
!  |     block 3, 0   | block 3,1   |  block 3,2  |  block 3,3  |
!  |     on 1, 0      |  on 1,1     |  on 1,0     |  on 1,1     |
!  |------------------|-------------|-------------|-------------|
!  |       [E1]       |   [E2]      |   [E3]      |   [E4]      |
!  |     block 4, 0   | block 4,1   | block 4,2   | block 4,3   |
!  |     on 0, 0      |  on 0,1     |  on 0,0     |  on 0,1     |
!  |                  |             |             |             |
!  |------------------------------------------------------------|
!
!   sendnorth executed on processor (0,0) will create a
!   send array containing two rows as follows:
!     row 1: the top rows of blocks C1 and C3
!     row 2: the top rows of blocks E1 and E3
!   this matrix will be then sent to  processor (1,0)
!
!   sendnorth executed on processor (1,1) will create a
!   send array containing three rows as follows:
!     row 1: the top rows of blocks B2 and B4
!     row 2: the top rows of blocks D2 and D4
!     row 3: a row of zeros
!
!   Each processor will receive a matrix matrix containing as
!   many rows as the local matrix has blocks, with the last row
!   being a row of zeros if the bottom most block contains the
!   last row of the distributed matrix.
!
!    Input arguments are as follows for send routines
!    subroutine sendeastborder(a,desca,send_buffer)
!    subroutine sendwestborder(a,desca,send_buffer)
!
!      a:     real or complex input array containing distributed matrix
!
!      desca: integer array descriptor corresponding to a
!
!      send_buffer: real or complex matrix of the same type as a
!                   must have at least as many columns as a and have at
!                   at least as many rows as the number of row block that
!                   the matrix a contains on the receiving processor
!                   This contains the sending buffer for the top rows
!
!
!    Input arguments are as follows for receive routines
!    subroutine rcveastborder(a,desca,send_buffer)
!    subroutine rcvwestborder(a,desca,send_buffer)
!
!      a:     real or complex input array containing distributed matrix
!
!      desca: integer array descriptor corresponding to a
!
!      rcv_buffer:  real or complex matrix of the same type as a
!                   must have at least as many columns as a and have at
!                   at least as many rows as the number of row block that
!                   the matrix a contains on the current processor. This
!                   will contain the border rows for each block on return
!

!       Subroutines called:
!           dgesd2d    from the blacs library
!           sgesd2d    from the blacs library
!           zgesd2d    from the blacs library
!           cgesd2d    from the blacs library
!           dgerv2d    from the blacs library
!           sgerv2d    from the blacs library
!           zgerv2d    from the blacs library
!           cgerv2d    from the blacs library

      contains

      subroutine dsendnorth(a,desca,send_buffer)
      real(long_t), intent(in)     :: a(:,:)
      real(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)     :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows - 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

!
!  calculate the row processor containing last global block
!
      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of blocks on local portion of the
!  distibuted matrix on the processor above the current processor
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+north_proc,nprows))/nprows

!
! check to make sure the send buffer size is large enough
!
      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
!  for each row block on the processor above us, copy
!  the top row into the send buffer. If the, block is
!  the bottom block of the global matrix, copy zeros
!
      do block = 1, last_block
      if( northmost(myrow,desca) ) then
        if( .not. south_most_block(block,myrow,desca)) then
          if( .not. south_most_block(block,north_proc,desca)) then
            send_buffer(block,1:size(a,2))=a(block*desca(MB_)+1,:)
          else
            send_buffer(block,1:size(a,2))=0
          endif
        endif
      else
        if( .not. south_most_block(block,north_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_)+1,:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! send the send buffer to the processor above the current processor
!
      call dgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               north_proc,mycol)

!
! return
!
      return
      end subroutine dsendnorth

      subroutine drcvsouth(a,desca,rcv_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing top rows of south processor
!

!
!  calculate the total number of blocks in on current processor
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!
      if (nprows .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. (desca(M_)+desca(MB_) -1)/desca(MB_)) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a(block*desca(MB_)+1,:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod(1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call dgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               south_proc,mycol)

      return
      end subroutine drcvsouth

      subroutine dsendsouth(a,desca,send_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod( 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
!
!  calculate the row processor containing last global block
!

      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of block on the processor north of us
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+south_proc,nprows))/nprows

!
! check to make sure the send buffer is big enough
!

      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        write(*,*) size(send_buffer,1), last_block
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
! loop over all of the block on the south processor and
! put the bottom row into the send buffer. If the south
! processor contains the top row, put zero in its place
!
      do block = 1, last_block
      if( southmost(myrow,desca) ) then
        if( .not. north_most_block(block,south_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      else
        if( .not. south_most_block(block,myrow,desca)) then
          send_buffer(block,1:size(a,2))=a(block*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! finally send to the south processor
!

      call dgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               south_proc,mycol)

      return
      end subroutine dsendsouth

      subroutine drcvnorth(a,desca,rcv_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing bottom rows of north processor
!

!
! calculate the number of local blocks of a on the current processor
!

      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!

      if (nprows .eq. 1)   then  ! copy from other portions of the array

       write(*,*) 'last_block is', last_block
       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a((block-1)*desca(MB_),:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows -1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call dgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               north_proc,mycol)

      return
      end subroutine drcvnorth

      subroutine ssendnorth(a,desca,send_buffer)
      real(short_t), intent(in)     :: a(:,:)
      real(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)     :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows - 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

!
!  calculate the row processor containing last global block
!
      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of blocks on local portion of the
!  distibuted matrix on the processor above the current processor
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+north_proc,nprows))/nprows

!
! check to make sure the send buffer size is large enough
!
      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
!  for each row block on the processor above us, copy
!  the top row into the send buffer. If the, block is
!  the bottom block of the global matrix, copy zeros
!
      do block = 1, last_block
      if( northmost(myrow,desca) ) then
        if( .not. south_most_block(block,myrow,desca)) then
          if( .not. south_most_block(block,north_proc,desca)) then
            send_buffer(block,1:size(a,2))=a(block*desca(MB_)+1,:)
          else
            send_buffer(block,1:size(a,2))=0
          endif
        endif
      else
        if( .not. south_most_block(block,north_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_)+1,:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! send the send buffer to the processor above the current processor
!
      call sgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               north_proc,mycol)

!
! return
!
      return
      end subroutine ssendnorth

      subroutine srcvsouth(a,desca,rcv_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing top rows of south processor
!

!
!  calculate the total number of blocks in on current processor
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!
      if (nprows .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. (desca(M_)+desca(MB_) -1)/desca(MB_)) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a(block*desca(MB_)+1,:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod(1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call sgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               south_proc,mycol)

      return
      end subroutine srcvsouth

      subroutine ssendsouth(a,desca,send_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod( 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
!
!  calculate the row processor containing last global block
!

      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of block on the processor north of us
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+south_proc,nprows))/nprows

!
! check to make sure the send buffer is big enough
!

      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        write(*,*) size(send_buffer,1), last_block
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
! loop over all of the block on the south processor and
! put the bottom row into the send buffer. If the south
! processor contains the top row, put zero in its place
!
      do block = 1, last_block
      if( southmost(myrow,desca) ) then
        if( .not. north_most_block(block,south_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      else
        if( .not. south_most_block(block,myrow,desca)) then
          send_buffer(block,1:size(a,2))=a(block*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! finally send to the south processor
!

      call sgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               south_proc,mycol)

      return
      end subroutine ssendsouth

      subroutine srcvnorth(a,desca,rcv_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing bottom rows of north processor
!

!
! calculate the number of local blocks of a on the current processor
!

      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!

      if (nprows .eq. 1)   then  ! copy from other portions of the array

       write(*,*) 'last_block is', last_block
       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a((block-1)*desca(MB_),:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows -1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call sgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               north_proc,mycol)

      return
      end subroutine srcvnorth

      subroutine csendnorth(a,desca,send_buffer)
      complex(short_t), intent(in)     :: a(:,:)
      complex(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)     :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows - 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

!
!  calculate the row processor containing last global block
!
      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of blocks on local portion of the
!  distibuted matrix on the processor above the current processor
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+north_proc,nprows))/nprows

!
! check to make sure the send buffer size is large enough
!
      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
!  for each row block on the processor above us, copy
!  the top row into the send buffer. If the, block is
!  the bottom block of the global matrix, copy zeros
!
      do block = 1, last_block
      if( northmost(myrow,desca) ) then
        if( .not. south_most_block(block,myrow,desca)) then
          if( .not. south_most_block(block,north_proc,desca)) then
            send_buffer(block,1:size(a,2))=a(block*desca(MB_)+1,:)
          else
            send_buffer(block,1:size(a,2))=0
          endif
        endif
      else
        if( .not. south_most_block(block,north_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_)+1,:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! send the send buffer to the processor above the current processor
!
      call cgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               north_proc,mycol)

!
! return
!
      return
      end subroutine csendnorth

      subroutine crcvsouth(a,desca,rcv_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing top rows of south processor
!

!
!  calculate the total number of blocks in on current processor
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!
      if (nprows .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. (desca(M_)+desca(MB_) -1)/desca(MB_)) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a(block*desca(MB_)+1,:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod(1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call cgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               south_proc,mycol)

      return
      end subroutine crcvsouth

      subroutine csendsouth(a,desca,send_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod( 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
!
!  calculate the row processor containing last global block
!

      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of block on the processor north of us
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+south_proc,nprows))/nprows

!
! check to make sure the send buffer is big enough
!

      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        write(*,*) size(send_buffer,1), last_block
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
! loop over all of the block on the south processor and
! put the bottom row into the send buffer. If the south
! processor contains the top row, put zero in its place
!
      do block = 1, last_block
      if( southmost(myrow,desca) ) then
        if( .not. north_most_block(block,south_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      else
        if( .not. south_most_block(block,myrow,desca)) then
          send_buffer(block,1:size(a,2))=a(block*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! finally send to the south processor
!

      call cgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               south_proc,mycol)

      return
      end subroutine csendsouth

      subroutine crcvnorth(a,desca,rcv_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing bottom rows of north processor
!

!
! calculate the number of local blocks of a on the current processor
!

      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!

      if (nprows .eq. 1)   then  ! copy from other portions of the array

       write(*,*) 'last_block is', last_block
       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a((block-1)*desca(MB_),:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows -1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call cgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               north_proc,mycol)

      return
      end subroutine crcvnorth

      subroutine zsendnorth(a,desca,send_buffer)
      complex(long_t), intent(in)     :: a(:,:)
      complex(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)     :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows - 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

!
!  calculate the row processor containing last global block
!
      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of blocks on local portion of the
!  distibuted matrix on the processor above the current processor
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+north_proc,nprows))/nprows

!
! check to make sure the send buffer size is large enough
!
      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
!  for each row block on the processor above us, copy
!  the top row into the send buffer. If the, block is
!  the bottom block of the global matrix, copy zeros
!
      do block = 1, last_block
      if( northmost(myrow,desca) ) then
        if( .not. south_most_block(block,myrow,desca)) then
          if( .not. south_most_block(block,north_proc,desca)) then
            send_buffer(block,1:size(a,2))=a(block*desca(MB_)+1,:)
          else
            send_buffer(block,1:size(a,2))=0
          endif
        endif
      else
        if( .not. south_most_block(block,north_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_)+1,:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! send the send buffer to the processor above the current processor
!
      call zgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               north_proc,mycol)

!
! return
!
      return
      end subroutine zsendnorth

      subroutine zrcvsouth(a,desca,rcv_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing top rows of south processor
!

!
!  calculate the total number of blocks in on current processor
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)

      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!
      if (nprows .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. (desca(M_)+desca(MB_) -1)/desca(MB_)) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a(block*desca(MB_)+1,:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod(1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call zgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               south_proc,mycol)

      return
      end subroutine zrcvsouth

      subroutine zsendsouth(a,desca,send_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      send_buffer :: matrix used to hold top rows of blocks within a
!

!
! check if we only have one row, if so, all the data is
! already on the current processor and we can do a quick return
!
      if (nprows .eq. 1)  return

!
!  determine where my rows is and which row is south of me
!
      south_proc = mod( 1 + myrow, nprows)

!
!  calculate the total number of row blocks in the global matrix
!
      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
!
!  calculate the row processor containing last global block
!

      prow_owning_last_block =                                             &
     &      mod(number_of_blocks-1+desca(RSRC_),nprows)

!
!  calculate the number of block on the processor north of us
!
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+south_proc,nprows))/nprows

!
! check to make sure the send buffer is big enough
!

      if( size(send_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in send_buffer'
        write(*,*) size(send_buffer,1), last_block
        call blacs_abort(icontext,1)
      endif

      if( size(send_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in sendbuffer'
        call blacs_abort(icontext,1)
      endif

!
! loop over all of the block on the south processor and
! put the bottom row into the send buffer. If the south
! processor contains the top row, put zero in its place
!
      do block = 1, last_block
      if( southmost(myrow,desca) ) then
        if( .not. north_most_block(block,south_proc,desca)) then
          send_buffer(block,1:size(a,2))=a((block-1)*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      else
        if( .not. south_most_block(block,myrow,desca)) then
          send_buffer(block,1:size(a,2))=a(block*desca(MB_),:)
        else
          send_buffer(block,1:size(a,2))=0
        endif
      endif
      enddo

!
! finally send to the south processor
!

      call zgesd2d(icontext,last_block,size(a,2),                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               south_proc,mycol)

      return
      end subroutine zsendsouth

      subroutine zrcvnorth(a,desca,rcv_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!    arguments :
!      a           :: local portion of distributed array
!      desca       :: array descriptor corresponding to a
!      rcv_buffer  :: return matrix containing bottom rows of north processor
!

!
! calculate the number of local blocks of a on the current processor
!

      number_of_blocks = (desca(M_)+desca(MB_) -1)/desca(MB_)
      last_block = (number_of_blocks + nprows -1 -                         &
     &      mod(nprows-desca(RSRC_)+myrow,nprows))/nprows

!
!  make sure that the receive buffer is big enough
!

      if( size(rcv_buffer,1) .lt. last_block) then
        write(*,*) ' not enough rows in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

      if( size(rcv_buffer,2) .lt. size(a,2)) then
        write(*,*) ' not enough columns in rcv_buffer'
        call blacs_abort(icontext,1)
      endif

!
!  if the number of processor rows is 1, we only need to copy
!

      if (nprows .eq. 1)   then  ! copy from other portions of the array

       write(*,*) 'last_block is', last_block
       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(block,1:size(a,2)) = 0
        else
          rcv_buffer(block,1:size(a,2)) = a((block-1)*desca(MB_),:)
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is north of me
!
      north_proc = mod(nprows -1 + myrow, nprows)

!
!  if there is more than one processor row, receive the border rows
!  from the processor to the south of us.
!

      call zgerv2d(icontext,last_block,size(a,2),                           &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               north_proc,mycol)

      return
      end subroutine zrcvnorth

        logical function north_most_block(block,proc,desc)
          implicit none
          integer, intent(in) :: block, proc
          integer, intent(in) :: desc(:)
          north_most_block = .false.
          if ( block .eq.1 .and. proc .eq. desc(RSRC_))                      &
     &         north_most_block = .true.
          return
        end function north_most_block

        logical function south_most_block(block,proc,desc)
          implicit none
          integer, intent(in) :: block, proc
         integer, intent(in) :: desc(:)
          south_most_block = .false.
          if (block .eq.(number_of_blocks+nprows-1)/nprows                    &
     &      .and. proc .eq. prow_owning_last_block)                           &
     &          south_most_block = .true.
        return
        end function south_most_block

        logical function northmost(proc,desc)
          implicit none
          integer, intent(in) :: proc
          integer, intent(in) :: desc(:)
          northmost = .false.
          if( desc(RSRC_) .eq. proc) northmost = .true.
          return
        end function northmost

        logical function southmost(proc,desc)
         implicit none
         integer, intent(in) :: proc
         integer, intent(in) :: desc(:)
         southmost = .false.
         if(mod(desc(RSRC_)-1+nprows,nprows).eq.proc)southmost=.true.
         return
        end function southmost
      end module northsouth


submodule(euler_interface_m) euler_prob_0025_m
    implicit none

contains

    module character(len=20) function euler0025()
        write (euler0025, "(i20)") ans(1000)
    end function euler0025

    integer function ans(n)
        integer, intent(in) :: n
        integer :: int_arr1(n), int_arr2(n)
        integer :: tmp(n), j, k

        int_arr1 = 0; int_arr2 = 0
        int_arr1(n) = 1; int_arr2(n) = 1
        k = 3

        loop_1: do

            tmp = int_arr1 + int_arr2
            loop_3: do j = n, 2, -1
                call carry(tmp(j - 1:j))
            end do loop_3
            int_arr1 = tmp

            if (int_arr1(1) /= 0) exit loop_1
            k = k + 1

            tmp = int_arr1 + int_arr2
            loop_6: do j = n, 2, -1
                call carry(tmp(j - 1:j))
            end do loop_6
            int_arr2 = tmp

            if (int_arr2(1) /= 0) exit loop_1
            k = k + 1

        end do loop_1

        ans = k
    end function ans

    subroutine carry(a)
        integer, intent(inout) :: a(2)
        integer :: tmp

        tmp = a(2)
        a(2) = a(2) - a(2)/10*10
        a(1) = a(1) + (tmp - a(2))/10
    end subroutine carry
end submodule euler_prob_0025_m


!###########################################################
! #                                                         #
! #                    THE LIDORT FAMILY                    #
! #                                                         #
! #      (LInearized Discrete Ordinate Radiative Transfer)  #
! #       --         -        -        -         -          #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! #  This Version :   3.7 F90                               #
! #  Release Date :   June 2014                             #
! #                                                         #
! #       NEW: THERMAL SUPPLEMENT INCLUDED    (3.2)         #
! #       NEW: OUTGOING SPHERICITY CORRECTION (3.2)         #
! #       NEW: TOTAL COLUMN JACOBIANS         (3.3)         #
! #       VLIDORT COMPATIBILITY               (3.4)         #
! #       THREADED/OPTIMIZED F90 code         (3.5)         #
! #       EXTERNAL SS / NEW I/O STRUCTURES    (3.6)         #
! #                                                         #
! #       Surface-leaving, BRDF Albedo-scaling     (3.7)    #
! #       Taylor series, BBF Jacobians, ThreadSafe (3.7)    #
! #                                                         #
! ###########################################################

!    #####################################################
!    #                                                   #
!    #   This Version of LIDORT comes with a GNU-style   #
!    #   license. Please read the license carefully.     #
!    #                                                   #
!    #####################################################

! ###############################################################
! #                                                             #
! #    Taylor series, small number expansions:                  #
! #             TAYLOR_SERIES_1                                 #
! #             TAYLOR_SERIES_2                                 #
! #             TAYLOR_SERIES_L_1                               #
! #             TAYLOR_SERIES_L_2a                              #
! #             TAYLOR_SERIES_L_2b                              #
! #                                                             #
! ###############################################################

MODULE lidort_Taylor_m

   USE LIDORT_PARS, only : max_Taylor_terms, Taylor_small, fpk, zero, one, two

PUBLIC

CONTAINS

subroutine Taylor_series_1 &
          ( order, eps, delta, udel, sm, mult )

!  Good for the particular and homogeneous-solution multipliers.
!      Small number expansion to any order up to 4.

!  Note: In LIDORT, this subroutine is applied to quantities of the form
!                [exp(-b*DELTA) - exp(-a*DELTA)]
!            q = -------------------------------
!                            (a-b)
!        where (a-b) has become small to the point of causing instability.
!        Note the positions of "a" and "b" in the numerator are swapped
!        from their positions in the denominator.
!
!        Using the above form for "q", the I/O for the subroutine is as
!        follows:
!        * EPS   = (a-b)
!        * DELTA = optical thickness (whole or partial layer)
!        * TERM2 = exp(-a*DELTA) (usually UDEL or WDEL)
!        * MULT  = q

   IMPLICIT NONE

!  arguments

   INTEGER  , INTENT(IN)  :: order
   REAL(FPK), INTENT(IN)  :: eps, delta, udel, sm
   REAL(FPK), INTENT(OUT) :: mult

!  local declarations

   integer   :: mterms, m
   REAL(FPK) :: power, d(0:max_Taylor_terms)

!  exp(De) expansion coefficients

   mterms = order + 1 ; d(0) = one
   do m = 1, mterms
      d(m) = delta * d(m-1) / real(m,fpk)
   enddo

!  evaluate multiplier

   mult = d(1) ; power = one
   do m = 2, mterms
      power = power * eps ; mult = mult + power * d(m)
   enddo
   mult = mult * udel * sm

!  Equivalent to the following, for order = 3 (highest power of eps)
!      power   = delta*eps ;  power2  = power*power ; power3 = power2 * power
!      mult = udel * sm * delta *(one + half*power + power2/6.0_fpk + power3/24.0_fpk)

!  Finish

   return
end subroutine Taylor_Series_1

subroutine Taylor_Series_2 &
       ( order, eps, y, delta, fac1, fac2, sm, mult )

!  Post-processing Green's function multipliers.
!    Small number expansion to any order

   implicit none

!  Arguments

   integer  , intent(in)  :: order
   real(fpk), intent(in)  :: eps, y, delta, fac1, fac2, sm
   real(fpk), intent(out) :: mult

!  Local

   integer    :: mterms, m, j
   real(fpk)  :: d(0:max_Taylor_terms), ac(0:max_Taylor_terms), cc(0:max_Taylor_terms), COF_0
   real(fpk)  :: Term_1(0:max_Taylor_terms),Term_2
   real(fpk)  :: Y1, power, power2

!  Zero output

   mult = zero

!  number of terms. One more if you have a double small-number

   mterms = order + 1
   if ( abs(y) .lt.Taylor_Small ) mterms = mterms+1

!  Delta powers

   d(0) = one
   do m = 1, mterms
      d(m) = delta * d(m-1) / real(m,fpk)
   enddo

!  Double small number expansion......Return e

   if ( abs(y) .lt.Taylor_Small ) then
      power = one ; power2 = one
      mult = d(2)
      do m = 3, mterms
         power  = power  * ( eps - y )
         power2 = power - y * power2
         mult = mult + d(m) * power2
      enddo
      mult = mult * fac1 * sm
      return
   endif

!  Develop ( 1 - x/s )^-1  for small x

   y1 = one / y
   ac(0) = one
   do m = 1, mterms
      ac(m) = y1 * ac(m-1)
   enddo

!  Develop ( 1 - x/s )^-1 . exp(Dx), for small x

   cc(0) = one
   do m = 1, mterms
      cc(m) = zero
      do j = 0, m
         cc(m) = cc(m) + ac(j)*d(m-j)
      enddo
   enddo

!  Term 1. Use AC and CC

   do m = 0, mterms
      Term_1(m) = fac1 * ac(m) - fac2 * cc(m)
   enddo

!  Term 2, then Check 0 coefficient is zero

   Term_2 = fac1 - fac2
   COF_0  = Term_1(0) - Term_2
!  write(*,*)'Coeffct zero = ',COF_0

!  Final answer

   power = one ; mult = Term_1(1)
   do m = 2, mterms
      power = eps * power
      mult = mult + power * Term_1(m)
   enddo
   mult = mult * sm * y1

!  Done

   return
end subroutine Taylor_Series_2

subroutine Taylor_series_L_1 ( order, eps, delta, ddot, kdot, Ldot, uterm, sm, L_mult )

!  Small number expansion for derivatives of Series 1 quantities
!     sm is required, but result is NOT SCALED

!   L_HMULT --> sm = user-secant   ,    Ldot = zero
!   L_GMULT --> sm = average_secant,    kdot/Ldot present
!   L_EMULT --> sm = user_secant   ,    Ldot = zero

   implicit none

!  arguments

   INTEGER  , INTENT(IN)  :: order
   REAL(FPK), INTENT(IN)  :: eps, delta, ddot, kdot, Ldot, uterm, sm
   REAL(FPK), INTENT(OUT) :: L_mult

!  local declarations

   integer   :: mterms, m, m1, m2
   REAL(FPK) :: power, d(0:max_Taylor_terms), series1, series2, series3

!  exp(De) expansion coefficients

   mterms = order + 2 ; d(0) = one
   do m = 1, mterms
      d(m) = delta * d(m-1) / real(m,fpk)
   enddo

!  Develop  series
!  Series 3 absent for HMULT/EMULT, only present for GMULT

   power = one
   series1 = d(0) - d(1)*sm
   series2 = d(2) - d(1)*delta
   series3 = d(2)
   do m = 1, order
      m1 = m + 1 ; m2 = m1 + 1
      power = power * eps
      series1 = series1 + power * (d(m)  - d(m1)*sm)
      series2 = series2 + power * (d(m2) - d(m1)*delta)
      series3 = series3 + power * d(m2)
   enddo

!  final

   L_mult = ( ddot*series1 - Ldot*series3 + kdot*series2 ) * uterm

   return
end subroutine Taylor_series_L_1

subroutine Taylor_Series_L_2a &
       ( order, eps, y, delta, deldot, lamdot, kdot, wudel, sm, L_mult )

   implicit none

!  Arguments

   integer  , intent(in)  :: order
   REAL(FPK), intent(in)  :: eps, y, delta, deldot, lamdot, kdot, wudel, sm
   REAL(FPK), intent(out) :: L_mult

!  Local

   integer    :: mterms1, mterms2, m, j
   REAL(FPK)  :: d(0:max_Taylor_terms), ac(0:max_Taylor_terms), bc(0:max_Taylor_terms)
   REAL(FPK)  :: cc(0:max_Taylor_terms), dc(0:max_Taylor_terms), COF_0
   REAL(FPK)  :: Term_1a(0:max_Taylor_terms), Term_1b(0:max_Taylor_terms), Term_3(0:max_Taylor_terms), Term_2
   REAL(FPK)  :: CONS1, CONS2, Y1, Nterm, power

!  Zero it

   L_mult = zero

!  number of terms

   mterms2 = order + 2
   mterms1 = order + 1  ! Need this for same order of accuracy as Radiances

!  Delta powers

   d(0) = one
   do m = 1, mterms2
      d(m) = delta * d(m-1) / real(m,fpk)
   enddo

!  Develop ( 1 - x/s )^-1  for small x, need Order+2 terms
!  Develop ( 1 - x/s )^-2  for small x, need Order+2 terms

   y1 = one / y
   ac(0) = one ; bc(0) = one
   do m = 1, mterms2
      ac(m) = y1 * ac(m-1)
      bc(m) = y1 * bc(m-1) * real(m+1,fpk) / real(m,fpk)
   enddo

!  Develop ( 1 - x/s )^-1 . exp(Dx), for small x, need Order+2 terms
!  Develop ( 1 - x/s )^-2 . exp(Dx), for small x, need Order+2 terms

   cc(0) = one ; dc(0) = one
   do m = 1, mterms2
      cc(m) = zero ; dc(m) = zero
      do j = 0, m
         cc(m) = cc(m) + ac(j)*d(m-j)
         dc(m) = dc(m) + bc(j)*d(m-j)
      enddo
   enddo

!  Check series expansions
!   write(*,*)(one-eps*y1)**(-one),ac(0) + eps*(ac(1) + eps*(ac(2) + eps*(ac(3) + eps*ac(4))))
!   write(*,*)(one-eps*y1)**(-two),bc(0) + eps*(bc(1) + eps*(bc(2) + eps*(bc(3) + eps*bc(4))))
!   write(*,*)(one-eps*y1)**(-one)*exp(eps*delta),cc(0) + eps*(cc(1) + eps*(cc(2) + eps*(cc(3) + eps*cc(4))))
!   write(*,*)(one-eps*y1)**(-two)*exp(eps*delta),dc(0) + eps*(dc(1) + eps*(dc(2) + eps*(dc(3) + eps*dc(4))))

!   pause

!  Term 1b: Use BC and DC

   CONS1 = - kdot * y1 ; CONS2 = - WUDEL * CONS1
   do m = 0, mterms1
      Term_1b(m) = CONS1 * bc(m) + CONS2 * dc(m)
   enddo

!  Term 1a: Use CC

   Nterm = deldot * y + delta * kdot
   CONS1 = Nterm * WUDEL ; CONS2 = - WUDEL * deldot
   Term_1a(0) = CONS1 * cc(0)
   do m = 1, mterms1
      Term_1a(m) = CONS1 * cc(m) + CONS2 * cc(m-1)
   enddo

!  Term 3. Use AC and CC

   CONS1 = - (Lamdot-kdot) ; CONS2 = - WUDEL * CONS1
   do m = 0, mterms1
      Term_3(m) = CONS1 * ac(m+1) + CONS2 * cc(m+1)
   enddo

!  Term 2

   CONS1  = lamdot * (WUDEL*delta - (one- WUDEL)*y1)
   CONS2  = deldot * y * WUDEL
   Term_2 = CONS1 + CONS2

!  Check 0 coefficient is zero

   COF_0 = Term_1a(0) + Term_1b(0) + Term_3(0) -  Term_2
!   write(*,*)COF_0

!  Final answer

   CONS1 = sm * y1 ;  power = one
   L_mult = CONS1 * ( Term_1a(1) + Term_1b(1) + Term_3(1) )
   do m = 2, mterms1
      power = eps * power
      L_mult = L_mult + CONS1 * power * ( Term_1a(m) + Term_1b(m) + Term_3(m) )
   enddo

!  Done

   return
end subroutine Taylor_Series_L_2a

subroutine Taylor_Series_L_2b &
       ( order, eps, y, delta, deldot, lamdot, kdot, wdel, udel, sm, lam, L_mult )

   implicit none

!  Arguments

   integer  , intent(in)  :: order
   REAL(FPK), intent(in)  :: eps, y, delta, deldot, lamdot, kdot, wdel, udel, sm, lam
   REAL(FPK), intent(out) :: L_mult
!  Local

   integer    :: mterms1, mterms2, m, j
   REAL(FPK)  :: d(0:max_Taylor_terms), ac(0:max_Taylor_terms), bc(0:max_Taylor_terms)
   REAL(FPK)  :: cc(0:max_Taylor_terms), dc(0:max_Taylor_terms), COF_0
   REAL(FPK)  :: Term_1a(0:max_Taylor_terms), Term_1b(0:max_Taylor_terms), Term_3(0:max_Taylor_terms), Term_2
   REAL(FPK)  :: CONS1, CONS2, CONS3, Y1, Nterm, power

!  Zero it

   L_mult = zero

!  number of terms

   mterms2 = order + 2
   mterms1 = order + 1  ! Need this for same order of accuracy as Radiances

!  Delta powers

   d(0) = one
   do m = 1, mterms2
      d(m) = delta * d(m-1) / real(m,fpk)
   enddo

!  Develop ( 1 + x/s )^-1  for small x, need Order+2 terms
!  Develop ( 1 + x/s )^-2  for small x, need Order+2 terms

   y1 = one / y
   ac(0) = one ; bc(0) = one
   do m = 1, mterms2
      ac(m) = - y1 * ac(m-1)
      bc(m) = - y1 * bc(m-1) * real(m+1,fpk) / real(m,fpk)
   enddo

!  Develop ( 1 + x/s )^-1 . exp(Dx), for small x, need Order+2 terms
!  Develop ( 1 + x/s )^-2 . exp(Dx), for small x, need Order+2 terms

   cc(0) = one ; dc(0) = one
   do m = 1, mterms2
      cc(m) = zero ; dc(m) = zero
      do j = 0, m
         cc(m) = cc(m) + ac(j)*d(m-j)
         dc(m) = dc(m) + bc(j)*d(m-j)
      enddo
   enddo

!  Check series expansions
!   write(*,*)(one+eps*y1)**(-one),ac(0) + eps*(ac(1) + eps*(ac(2) + eps*(ac(3) + eps*ac(4))))
!   write(*,*)(one+eps*y1)**(-two),bc(0) + eps*(bc(1) + eps*(bc(2) + eps*(bc(3) + eps*bc(4))))
!   write(*,*)(one+eps*y1)**(-one)*exp(eps*delta),cc(0) + eps*(cc(1) + eps*(cc(2) + eps*(cc(3) + eps*cc(4))))
!   write(*,*)(one+eps*y1)**(-two)*exp(eps*delta),dc(0) + eps*(dc(1) + eps*(dc(2) + eps*(dc(3) + eps*dc(4))))
!   pause'Exp check'

!  Term 1b: Use BC and DC

   CONS3 = kdot * y1 ; CONS1 =  WDEL * CONS3 ; CONS2 = - UDEL * CONS3
   do m = 0, mterms1
      Term_1b(m) = CONS1 * dc(m) + CONS2 * bc(m)
   enddo

!  Term 1a: Use AC and CC

   Nterm = deldot * lam + delta * kdot
   CONS1 = - Nterm * WDEL ; CONS2 = WDEL * deldot ; CONS3 = UDEL * deldot * sm
   Term_1a(0) = CONS1 * cc(0) + CONS3 * ac(0)
   do m = 1, mterms1
      Term_1a(m) = CONS1 * cc(m) + CONS2 * cc(m-1) + CONS3 * ac(m)
   enddo

!  Term 3. Use AC and CC

   CONS3 = (Lamdot-kdot) ; CONS1 = UDEL * CONS3 ; CONS2 = - WDEL * CONS3
   do m = 0, mterms1
      Term_3(m) = CONS1 * ac(m+1) + CONS2 * cc(m+1)
   enddo

!  Term 2

   CONS1  = lamdot * (WDEL*delta + ( WDEL - UDEL )*y1)
   CONS2  = deldot * (Wdel * lam - UDEL*y1)
   Term_2 = CONS1 + CONS2

!  Check 0 coefficient is zero

   COF_0 = Term_1a(0) + Term_1b(0) + Term_3(0) -  Term_2
!   write(*,*)COF_0

!  Final answer

   CONS1 = sm * y1 ;  power = one
   L_mult = CONS1 * ( Term_1a(1) + Term_1b(1) + Term_3(1) )
   do m = 2, mterms1
      power = eps * power
      L_mult = L_mult + CONS1 * power * ( Term_1a(m) + Term_1b(m) + Term_3(m) )
   enddo

!  Done

   return
end subroutine Taylor_Series_L_2b

!  Finish module

END MODULE lidort_Taylor_m


      SUBROUTINE cumpoi(s,xlam,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMPOI(S,XLAM,CUM,CCUM)
C                    CUMulative POIsson distribution
C
C
C                              Function
C
C
C     Returns the  probability  of  S   or  fewer events in  a   Poisson
C     distribution with mean XLAM.
C
C
C                              Arguments
C
C
C     S --> Upper limit of cumulation of the Poisson.
C                                                  S is DOUBLE PRECISION
C
C     XLAM --> Mean of the Poisson distribution.
C                                                  XLAM is DOUBLE PRECIS
C
C     CUM <-- Cumulative poisson distribution.
C                                        CUM is DOUBLE PRECISION
C
C     CCUM <-- Compliment of Cumulative poisson distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C
C                              Method
C
C
C     Uses formula  26.4.21   of   Abramowitz and  Stegun,  Handbook  of
C     Mathematical   Functions  to reduce   the   cumulative Poisson  to
C     the cumulative chi-square distribution.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION s,xlam,cum,ccum
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION chi,df
C     ..
C     .. External Subroutines ..
      EXTERNAL cumchi
C     ..
C     .. Executable Statements ..
      df = 2.0D0* (s+1.0D0)
      chi = 2.0D0*xlam
      CALL cumchi(chi,df,ccum,cum)
      RETURN

      END


c***************************************************************
c  F-K: @(#) kernel.f			1.0 4/29/2000
c
c  Copyright (c) 2000 by L. Zhu
c  See README file for copying and redistribution conditions.
c
c subroutine compute free-surface displacement kernels from a point
c source in multi-layer medium using the Haskell propagator matrix.
c
c	reference:
c		Haskell (1964), BSSA
c		Wang and Herrmann (1980), BSSA
c
c	with some modifications:
c	(1) modify the definition of B and K and put back w^2 so all matrix
c	    elements are either dimensionless or in in shear modular unit.
c	(2) suppress overflow by factoring out e^(Re(ra+rb)*d) in matrix
c	    elements.
c	(3) the cordinate is Z up, R outward and T counterclockwise
c Input:
c	k	wavenumber
c	/model/	velocity model (see include file)
c Output:
c	u(i,3)	kernels for azimuthal mode i = 0, 1, 2 in the order of Z, R, T.
c		Note that 1/2*pi*mu is omitted.
c called by
c	main 				in fk.f
c
c subroutines called:
c	layerParameter(), propagateZ()	in haskell.f
c	initialG(), propagateG()	in compound.f
c	setSource()			in compound.f
c***************************************************************
      subroutine kernel(k,u)
      include	'constants.h'
      include	'model.h'
      integer	i, lay
      real	k, k2
      complex	u(3,3), sj(3,6)
      complex*16 g(7), z(3,6)

      k2 = k*k
c propagation - from bottom to surface
      do lay = mb, 1, -1

	call layerParameter(k, lay)

        if (lay.eq.mb) then
	   call initialG(g)
        else
	   call propagateG(g)
        endif

	if (lay.eq.srclayer) then
	   call source(src,k,ka(lay)/kb(lay),rho(lay)*k2/kb(lay),sj)
	   call setSource(sj, g, z)
	endif

	if (lay.lt.srclayer) call propagateZ(z)

      enddo

c displacement kernel, 1 k from k-integration, k2 from k2/w2
      k2 = k*k2
      g(1) = k2/g(1)
      g(6) = k2/g(6)
      do i = 1, 3
         u(i,1) =-z(i,1)*g(1)
         u(i,2) = z(i,2)*g(1)
         u(i,3) = z(i,5)*g(6)
      enddo

      return
      end


! Initialization of the pressure solver using FFT/cosine transform.
!
! Author: Anthony Ge (KTH)
! Date:   25 January 2017
!------------------------------------------------------------------

module mod_initsolver

  use mod_solver_common
  use mod_param
  use decomp_2d

  implicit none

  private
  public initsolver

contains

  subroutine initsolver

    integer :: i,j,k,iv,jv
    real :: xrt(itot), yrt(jtot), zrt(kmax)
    real :: bb

    select case(BC_in_y)

    case('Periodic')

       ! Generate tridiagonal matrix

       allocate (a(kmax))
       allocate (b(kmax))
       allocate (c(kmax))

       do k=1,kmax
          a(k) = dzi*dzi
          c(k) = dzi*dzi
          b(k) = -(a(k) + c(k))
       enddo

       ! Neumann boundary condition for correction pressure in z-direction;
       ! consistent with no-penetration condition for prediction velocity
       ! at solid walls (Channel)

       b(1) = b(1) + a(1)
       b(kmax) = b(kmax) + c(kmax)
       a(1) = 0.
       c(kmax) = 0.

       ! set lookup tables.

       call vrffti(itot,wi)
       call vrffti(jtot,wj)

       ! generate eigenvalues ( xrt and yrt ).

       ! x direction

       do i=3,itot,2
          xrt(i-1) = -4.*dxi*dxi*(sin(float((i-1))*pi/(2.*itot)))**2
          xrt(i) = xrt(i-1)
       enddo
       xrt(1   ) = 0.
       xrt(itot) = -4.*dxi*dxi

       ! y direction

       do j=3,jtot,2
          yrt(j-1) = -4.*dyi*dyi*(sin(float((j-1))*pi/(2.*jtot)))**2
          yrt(j  ) = yrt(j-1)
       enddo
       yrt(1   ) = 0.
       yrt(jtot) = -4.*dyi*dyi

       do j=1,jmax
          jv = j + zstart(2) - 1
          do i=1,imax
             iv = i + zstart(1) - 1
             xyrt(i,j) = xrt(iv)+yrt(jv)
          enddo
       enddo

    case('Walls','InOut','OutOut')

       ! Generate tridiagonal matrix

       allocate (a(jtot))
       allocate (b(jtot))
       allocate (c(jtot))

       do j=1,jtot
          a(j) = dyi*dyi
          c(j) = dyi*dyi
          b(j) = -(a(j) + c(j))
       enddo

       ! Neumann boundary condition for correction pressure in z-direction;
       ! consistent with no-penetration condition for prediction velocity
       ! at solid walls (Channel)

       select case(BC_in_y)
       case('Walls')

          b(1) = b(1) + a(1)
          b(jtot) = b(jtot) + c(jtot)
          a(1) = 0.
          c(jtot) = 0.

       case('InOut')

          b(1) = b(1) + a(1)
          b(jtot) = b(jtot) - c(jtot)
          a(1) = 0.
          c(jtot) = 0.

       case('OutOut') !####

          b(1) = b(1) - a(1)
          b(jtot) = b(jtot) - c(jtot)
          a(1) = 0.
          c(jtot) = 0.

       end select

       ! set lookup tables.

       call vrffti(itot,wi)
       call vcosqi(kmax,wk)

       ! generate eigenvalues ( xrt and yrt ).

       ! x direction

       do i=3,itot,2
          xrt(i-1) = -4.*dxi*dxi*(sin(float((i-1))*pi/(2.*itot)))**2
          xrt(i) = xrt(i-1)
       enddo
       xrt(1   ) = 0.
       xrt(itot) = -4.*dxi*dxi

       ! z direction

       do k=1,kmax
          zrt(k) = (dzi**2)*( -2. + 2.*cos(real(k-1)*pi/kmax) )
       enddo

       do j=1,jmax
          do k=1,kmax
             do i=1,imax
                iv = i + zstart(1) - 1
                xzrt(i,j,k) = xrt(iv)+zrt(k)
             enddo
          enddo
       enddo

    end select

    return
  end subroutine initsolver

end module mod_initsolver


*DECK FMTGEN
      SUBROUTINE FMTGEN(F,T,M,ICK)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION F(M)
      COMMON/IO/IN,IOUT,IPUNCH
      COMMON/FMCONS/FOUR,ONE,HALF,TWO,ZERO,TEN,TENM9,F20,F42,F500
      COMMON/FM/GA(17),RPITWO,FMZERO(17),TOL,CUT0S,CUTSM,CUTML
      EQUIVALENCE(APPROX,OLDSUM)
 2001 FORMAT(41H0FAILURE IN FMGEN FOR SMALL T   IX > 50, /
     $ 6H IX = ,I3,7H,  T = ,D20.14)
C
C     ICK IS AN ERROR INDICATOR.
C     ON RETURN, ICK=0 IMPLIES THAT ALL IS WELL.
C     IF ON RETURN, ICK IS NON-ZERO, THE ASSYMPTOTIC EXPANSION
C     HAS FAILED.
      ICK=0
C     TEST FOR TYPE OF ALGORITHM.
      IF( ABS(T).GT.CUT0S)GO TO 3
C*********************************************************************
C        FILL F(M) FOR ARGUMENT OF ZERO.
C*********************************************************************
      DO 2 I=1,M
    2 F(I)=FMZERO(I)
      RETURN
C
C     TEST FOR EVALUATION OF THE EXP.
    3 TEXP=ZERO
      IF( ABS(T).GE.CUTML)GO TO 150
      TEXP= EXP(-T)
      IF( ABS(T).GE.CUTSM)GO TO 80
C*********************************************************************
C        0 .LT. T .LT. 10
C*********************************************************************
      A= FLOAT(M-1)+HALF
      TERM=ONE/A
      SUM=TERM
      DO 20 IX=2,400
      A=A+ONE
      TERM=TERM*T/A
      SUM=SUM+TERM
      IF( ABS(TERM/SUM)-TOL)30,20,20
   20 CONTINUE
      WRITE(IOUT,2001)IX,T
C***      CALL LNK1E
      STOP
   30 F(M)=HALF*SUM*TEXP
      GO TO 160
C
C*********************************************************************
C        10 .LE. T .LT. 42
C*********************************************************************
   80 A= FLOAT(M-1)
      B=A+HALF
      A=A-HALF
      TX=ONE/T
      MM1=M-1
      APPROX=RPITWO* SQRT(TX)*(TX**MM1)
      IF(MM1)90,110,90
   90 DO 100 IX=1,MM1
      B=B-ONE
  100 APPROX=APPROX*B
  110 FIMULT=HALF*TEXP*TX
      SUM=ZERO
      IF(FIMULT)120,140,120
  120 FIPROP=FIMULT/APPROX
      TERM=ONE
      SUM =ONE
      NOTRMS=  INT(T)+MM1
      DO 130 IX=2,NOTRMS
      TERM=TERM*A*TX
      SUM=SUM+TERM
      IF( ABS(TERM*FIPROP/SUM)-TOL)140,140,130
  130 A=A-ONE
      RATIO= ABS((TERM*FIPROP/SUM))
C     WRITE(IOUT,2002)T,RATIO
      ICK=1
      RETURN
  140 F(M)=APPROX-FIMULT*SUM
      GO TO 160
C*********************************************************************
C        T .GE. 42
C*********************************************************************
  150 TX= FLOAT(M)-HALF
      F(M)=HALF*GA(M)/(T**TX)
C*********************************************************************
C        RECUR DOWNWARDS TO F(1)
C*********************************************************************
  160 TX=T+T
      SUM= FLOAT(M+M-3)
      MM1=M-1
      IF(MM1)170,190,170
  170 DO 180 IX=1,MM1
      F(M-IX)=(TX*F(M-IX+1)+TEXP)/SUM
  180 SUM=SUM-TWO
  190 RETURN
      END


module NR_module

use Structure
use bar
use Matrix_op
use gnuplot_fortran
use local_stage_NR

implicit none

  type :: NR_struct

    double precision, dimension(:,:), allocatable :: U
    double precision, dimension(:,:,:,:), allocatable :: sigma,eps,d_Ep
    !double precision, dimension(:,:), allocatable :: Kss ! Mss

  end type NR_struct

  type(NR_struct) :: NR

contains

subroutine NR_solver(I,Sop)

    type(Input), intent(in) :: I
    type(Space_op), intent(in) :: Sop

    !double precision, dimension(I%n,I%n) :: M ! Total mass matrix
    double precision, dimension(I%n,I%n) :: K ! Total stifness matrix
    !double precision, dimension(I%ns,I%ns) :: Mss ! Free dofs mass matrix
    double precision, dimension(I%ns,I%ns) :: Kss ! Free dofs stifness matrix
    double precision, dimension(I%ns,I%ns) :: ChKss ! Free dofs stifness matrix

    double precision, dimension(I%ns,I%ns) :: invKss ! inverse of Kss
    double precision, dimension(I%ns,2) :: Kud ! stiffness matrix related to fix dofs
    double precision, dimension(I%ns,I%ntNR) :: Fud,x
    double precision, dimension(I%ns,I%ntNR-1) :: dfud

    double precision, dimension(I%n,I%ntNR) :: U   ! Displacement
    double precision, dimension(I%n,I%ntNR) :: Ut   ! Displacement
    double precision, dimension(I%n,I%ntNR) :: Utt   ! Displacement

    double precision, dimension(2,I%ntNR) :: Ud   ! imposed Displacement

    double precision, dimension(I%ns,I%ntNR) :: Us ! free dofs displacement
    double precision, dimension(I%ns,I%ntNR) :: Ust ! free dofs displacement
    double precision, dimension(I%ns,I%ntNR) :: Ustt ! free dofs displacement

    double precision, dimension(I%ntNR) :: vect
    double precision, dimension(Sop%comp,I%ngps,I%Nx,I%ntNR) :: eps,sigma,d_Ep,Ep !(I%Tngps,I%ntNR)

    integer, dimension(4) :: siz
    integer, dimension(3) :: sizr
    integer :: iter, iT
    double precision :: error

    double precision, dimension(I%ns,I%ntNR) :: g
    double precision, dimension(I%ns,1) :: res, dUs
    double precision, dimension(I%n,1) :: F
    double precision, dimension(I%ns) :: xs

    integer, dimension(I%ntNR-1) ::  vec1, vec2

    double precision, dimension(Sop%comp,I%ngps,I%Nx) :: sigma_a, eps_a, d_Epa

    integer :: ielm
    integer :: ns, nrhs, info, lda, ldb   ! dimension of the matrix that must be inverted.
    !integer, allocatable, dimension(:) :: ipiv
    integer, dimension(I%ns) :: ipiv

    ! Assignation of the final solution to structure NR:
    siz = (/Sop%comp,I%ngps,I%Nx,I%ntNR/)
    sizr = (/Sop%comp,I%ngps,I%Nx/)

    allocate(NR%U(I%n,I%ntNR))
    allocate(NR%eps(siz(1),siz(2),siz(3),siz(4)))
    allocate(NR%sigma(siz(1),siz(2),siz(3),siz(4)))
    allocate(NR%d_Ep(siz(1),siz(2),siz(3),siz(4)))

    ! Init:
    eps = 0; sigma = 0; d_Ep = 0; Ep = 0; U = 0;
    Us = 0; Ust = 0; Ustt = 0;
    g = 0; res = 0; dUs = 0;

    ns = I%ns;

    ! Assembly:
    do ielm = 1, I%Nx
       !M( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm)  ) = M( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm) ) + Sop%Melm
       K( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm)  ) = K( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm) ) + Sop%Kelm
    end do

    ! Imposed displacement:
    U(1,:) = 0 ! Fix condition.
    U(I%n,:) = I%udNR ! displacement condition.

    ! Dofs free and imposed of the matrices used:
    Kss=K(Sop%dof_free,Sop%dof_free)
    Kud=K(Sop%dof_free,Sop%dof_imposed)
    ChKss = cholesky(Kss) ! Cholesky decomposition of Kss

    ! Imposed displacement and generated force.
    Ud = U(Sop%dof_imposed,:)
    Fud=matmul(Kud,Ud) ! Force due to the imposition of displacements.

    if (.false.) then ! Elastic solution

      !! Resolution (code Blas Lapack):
      !ns = size(Kss,1)
      nrhs = size(Fud,2)
      !print*, ns,nrhs
      lda = ns; ldb = ns
      !allocate(ipiv(ns))
      x = -Fud
      call dgesv(ns,nrhs,Kss,lda,ipiv,x,ldb,info)
      Us = x

      ! Displacement, strain and stress:
      U(Sop%dof_free,:) = Us
      eps = reshape( matmul(Sop%B,U) , siz)
      sigma = reshape(matmul(Sop%He, reshape( eps, (/Sop%comp, size(eps)/Sop%comp/))), siz )
      !sigma = reshape(matmul(Sop%He, reshape( eps, (/Sop%comp, size(eps)/Sop%comp/))), (/size(eps,1),I%ntNR/) )

      NR%U = U
      NR%eps = eps
      NR%sigma = sigma

      print*, "SOLUTION DONE, ERROR:", 100*norm2( matmul(Kss,Us) + Fud )/norm2(Fud) , "[%]."

    else ! Elasto-visco-plasticity

      vec1 = incr(2,I%ntNR)
      vec2 = incr(1,I%ntNR-1)
      dfud = Fud(:,vec1) - Fud(:,vec2);

      do iT = 2,I%ntNR

          d_Epa=0; ! derivative in time of the auxiliary plasticity function (Initialization).
          !iT=iT+1
          !Ustt(:,iT)=0;
          !Us(:,iT) = Us(:,iT-1) + I%dt*Ust(:,iT-1) + (0.5-I%beta)*(I%dt**2)*Ustt(:,iT-1) +(I%dt**2)*I%beta*Ustt(:,iT);
          !Ust(:,iT) = Ust(:,iT-1) + (1-I%gamma)*I%dt*Ustt(:,iT-1) + I%dt*I%gamma*Ustt(:,iT);
          Us(:,iT) = Us(:,iT-1)

          ! (Initialization) Boundary conditions imposed:
          res(:,1) = g(:,iT-1);
          !du=transpose(LM)\(LM\(-res - dfud(:,iT-1)));

          ! Resolution:
          if (.true.) then

            xs = -res(:,1) - dfud(:,iT-1)
            call inv_chol(ChKss,xs)
            dUs(:,1) = xs

          else

            !!!!!!!!!! Fast inverse:
            !ns, nrhs, lda, ldb, ipiv, x
            !ns = size(Mss,1)
            nrhs = 1
            lda = ns; ldb = ns
            xs = -res(:,1) - dfud(:,iT-1)
            call dgesv(ns,nrhs,Kss,lda,ipiv,xs,ldb,info)
            dUs(:,1) = xs

          end if

          !print*, dUs
          !stop

          Us(:,iT)=Us(:,iT)+dUs(:,1);
          !Ust(:,iT)=Ust(:,iT)+dUs(:,1)*(I%gamma/(I%beta*I%dt));
          !Ustt(:,iT)=Ustt(:,iT)+dUs(:,1)*(1/(I%beta*I%dt**2));

          error=100; iter=0;

          do while (I%NR_error_min <= error )

            iter=iter+1

            if (iter>1) then

                if (.true.) then

                  xs = -res(:,1)
                  call inv_chol(ChKss,xs)
                  dUs(:,1) = xs

                else

                  !!!!!!!!!! Fast inverse:
                  nrhs = 1
                  lda = ns; ldb = ns
                  xs = -res(:,1)
                  call dgesv(ns,nrhs,Kss,lda,ipiv,xs,ldb,info)
                  dUs(:,1) = xs

                end if
                Us(:,iT) = Us(:,iT) + dUs(:,1);
                !Ust(:,iT) = Ust(:,iT) + dUs(:,1)*(I%gamma/(I%beta*I%dt));
                !Ustt(:,iT) = Ustt(:,iT) + dUs(:,1)*(1/(I%beta*I%dt**2));
            end if

            U(Sop%dof_free,iT) = Us(:,iT)
            eps_a = reshape( matmul(Sop%B,U(:,iT)), sizr )

            ! Stress calculation:
            sigma_a = I%Hooke*(eps_a-(Ep(:,:,:,iT-1)+I%dt*d_Epa))

            ! Derivative in time of the plasticity.
            d_Epa = local_stage_vp_NR(I,Sop,sigma_a)

            ! Calculation of g:
            F = I%A*( matmul( transpose(Sop%Bw) , reshape(sigma_a, (/size(sigma_a),1/)  ) ) )
            g(:,iT) = F(Sop%dof_free,1)

            ! Residual function:
            res(:,1) = g(:,iT)
            !error=sqrt(transpose(res)*res);
            error = norm2(res)

          end do ! while

          eps(:,:,:,iT)=eps_a;  ! total deformation.
          Ep(:,:,:,iT) = Ep(:,:,:,iT-1) + I%dt*d_Epa; ! Riemman integration.
          d_Ep(:,:,:,iT)=d_Epa;
          sigma(:,:,:,iT)=sigma_a;

          print*, iT

        end do ! end for iT<=nt

        ! Save the results on NR:
        NR%U = U
        NR%eps = eps    !matmul(Sop%B,Elast%U) ! Sop%B*Elast%U
        NR%d_Ep = d_Ep
        NR%sigma = sigma  !matmul(Sop%He,Elast%eps)  ! Sop%He*Elast%eps

        ! Error determination:
        print*, "SOLUTION DONE, ERROR:", norm2( g )

    end if

  end subroutine NR_solver

end module NR_module


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE CROSSC(WAVE,S1,S2,NPOINT,NBINS,MAXD,WCENT,ICENT,
     *                    DELW,DELI,TOTS1,TOTS2,NGOOD)
*
* Module Number: HRS/FOS utility
*
* Module Name: CROSSC
*
* Keyphrase:
* ----------
*       Compute offset by cross-correlation
*
* Description:
* ------------
*       This routine divides the input spectra into nbins and computes
*       an offset for each bin using cross correlation of the two
*       spectra.
*
* Fortran Name: crossc.for
*
* Keywords of accessed files and tables:
* --------------------------------------
*       none
*
* Subroutines Called:
* -------------------
* CDBS:
*       none
* SDAS:
*       none
*
* History:
* --------
* version         date            Author          Description
*    1          3/26/87         D. Lindler      Designed and coded
*    2          9/25/87         D. Lindler      New SDAS standards
*-------------------------------------------------------------------------
*
* Input paramters
*
*       wave - wavelength vector for the first spectra (real*8)
*       s1 - the first spectra (real*8)
*       s2 - the second spectra (real*8)
*       npoint - number of points in wave, s1, and s2 (integer)
*       nbins - number of bins to devide data into
*       maxd - max distance to search for offset
*
* Output paramters
*
*       wcent - central wavelength for each offset computed (real*8)
*       icent - central index number of each offset computed (real*8)
*       delw - offsets in wavelength units (real*8)
*       dels - offsets in sample units (real*8)
*       tots1 - total counts in each bin of s1 (real*8)
*       tots2 - total counts in each bin of spectrum s2 (real*8)
*       ngood - number of offsets computed (integer)
*
	IMPLICIT NONE
        DOUBLE PRECISION WAVE(*),S1(*),S2(*),WCENT(*),ICENT(*),
     *       DELW(*),DELI(*),TOTS2(*),TOTS1(*)
        INTEGER NPOINT,NBINS,MAXD,NGOOD
C
C LOCAL VARIABLES
C
        DOUBLE PRECISION C(100),SUM,MAXC,RK,SUM12,AVE1,AVE2,
     *        SUM2SQ,SUM1SQ,RS1,RS2,DENOM,TOTAL1,TOTAL2
        INTEGER I,J,K,IOFF,I1OFF,IC,WIDTH,N
C
C-----------------------------------------------------------------------------
C
C COMPUTE SIZE OF BINS AND SEARCH WIDTH
C
        WIDTH=MAXD*2+1
        N=(NPOINT-WIDTH)/NBINS
C
C LOOP ON EACH BIN
C
        NGOOD=0
        DO 100 I=1,NBINS
C
C COMPUTE OFFSET FOR EACH BIN
C
                IOFF=(I-1)*N+WIDTH/2
C
C COMPUTE AVERAGE OF SECOND SPECTRA FOR THE BIN
C
                SUM=0.0
                DO 5 K=1,N
                        SUM=SUM+S2(IOFF+K)
5               CONTINUE
                AVE2=SUM/N
C
C LOOP ON EACH OFFSET IN SEARCH WIDTH
C
                DO 50 J=1,WIDTH
C
C OFFSET FOR FIRST SPECTRA
C
                        I1OFF=IOFF+J-MAXD-1
C
C COMPUTE AVERAGE FOR BIN IN FIRST SPECTRUM
C
                        SUM=0.0
                        DO 10 K=1,N
                                SUM=SUM+S1(I1OFF+K)
10                      CONTINUE
                        AVE1=SUM/N
C
C COMPUTE TOTALS OF: (S1-AVE1)*(S2-AVE2)
C                    (S1-AVE1)**2
C                    (S2-AVE2)**2
C
                        SUM12=0.0
                        SUM1SQ=0.0
                        SUM2SQ=0.0
                        DO 20 K=1,N
                                RS1=S1(I1OFF+K)-AVE1
                                RS2=S2(IOFF+K)-AVE2
                                SUM1SQ=SUM1SQ+RS1*RS1
                                SUM2SQ=SUM2SQ+RS2*RS2
                                SUM12=SUM12+RS2*RS1
20                      CONTINUE
C
C PLACE SUM IN CORRELATION MATRIX
C
                        DENOM=SQRT(SUM1SQ)*SQRT(SUM2SQ)
                        IF(DENOM.EQ.0) GO TO 100
                        C(J)=SUM12/DENOM
50              CONTINUE
C
C FIND MAXIMUM OF CORRELATION MATRIX, MAXC, AND POSITION OF MAXIMUM, K
C
                K=0
                MAXC=0.0
                DO 60 J=1,WIDTH
                        IF(C(J).GT.MAXC)THEN
                                MAXC=C(J)
                                K=J
                        ENDIF
60              CONTINUE
C
C DON'T USE IF MAXIMUM IS ON EDGE OF CORRELTAION MATRIX
C
                IF((K.LT.2).OR.(K.EQ.WIDTH))GO TO 100
C
C USE QUADRATIC REFINE TO COMPUTE EXACT OFFSET (MAX. OF QUADRATIC FIT TO
C       C(K-1), C(K) AND C(K+1)
C
                RK=(C(K-1)-C(K))/(C(K-1)+C(K+1)-2.0*C(K))-0.5
C
C UPDATE OUTPUT VECTORS
C
                NGOOD=NGOOD+1
                DELI(NGOOD)=MAXD-K-RK+1.0
                IC=IOFF+N/2+1
                ICENT(NGOOD)=IC
                WCENT(NGOOD)=WAVE(IC)
C
C COMPUTE TOTAL IN SPECTRA FOR BIN
C
                TOTAL1=0.0
                TOTAL2=0.0
                DO 70 J=1,N
                        TOTAL1=TOTAL1+S1(IOFF+J)
                        TOTAL2=TOTAL2+S2(IOFF+J)
70              CONTINUE
                TOTS1(NGOOD)=TOTAL1
                TOTS2(NGOOD)=TOTAL2
C
C COMPUTE WAVELENGTH OFFSET FROM INDEX OFFSET
C
                DELW(NGOOD)=DELI(NGOOD)*(WAVE(IC+1)-WAVE(IC-1))/2.0
100     CONTINUE
        RETURN
        END