      SUBROUTINE TPERT(IPAIR,GA,DT)
*
*
*       Perturbation time scale.
*       ------------------------
*
      INCLUDE 'common6.h'
*
*
*       Set c.m. index and initialize scalars.
      I = N + IPAIR
      FMAX = 0.0
      DTIN = 1.0E+20
      JCLOSE = 0
      NNB1 = LIST(1,I) + 1
*
*       Check rare case of no neighbours.
      IF (NNB1.LE.1) THEN
          DT = 2.0*STEPR(I)
          GO TO 20
      END IF
*
*       Find the most likely perturbers (first approach & maximum force).
      DO 10 L = 2,NNB1
          J = LIST(L,I)
          RIJ2 = 0.0
          RDOT = 0.0
*
          DO 6 K = 1,3
              XREL = X(K,J) - X(K,I)
              VREL = XDOT(K,J) - XDOT(K,I)
              RIJ2 = RIJ2 + XREL**2
              RDOT = RDOT + XREL*VREL
    6     CONTINUE
*
          VR = RDOT/RIJ2
          IF (VR.LT.DTIN) THEN
              DTIN = VR
*       Note DTIN is inverse travel time to include case of no RDOT < 0.
              RCRIT2 = RIJ2
              JCRIT = J
          END IF
          FIJ = (BODY(I) + BODY(J))/RIJ2
          IF (FIJ.GT.FMAX) THEN
              FMAX = FIJ
              RJMIN2 = RIJ2
              JCLOSE = J
          END IF
   10 CONTINUE
*
*       Form radial velocity of body with shortest approach time (if any).
      RCRIT = SQRT(RCRIT2)
      RDOT = RCRIT*ABS(DTIN)
      A1 = 2.0/(BODY(I)*GA)
      SEMI = -0.5*BODY(I)/H(IPAIR)
*
*       Use the actual apocentre for unperturbed travel time.
      ECC2 = (1.0 - R(IPAIR)/SEMI)**2 + TDOT2(IPAIR)**2/(BODY(I)*SEMI)
      RI = SEMI*(1.0 + SQRT(ECC2))
*
*       Estimate time interval to reach tidal perturbation of GA.
      DT = (RCRIT - RI*(BODY(JCRIT)*A1)**0.3333)/RDOT
*
*       Compare the travel time based on acceleration only.
      DTMAX = SQRT(2.0D0*ABS(DT)*RDOT*RCRIT2/(BODY(I) + BODY(JCRIT)))
      DT = MIN(DT,DTMAX)
*
*       Skip dominant force test if there is only one critical body.
      IF (JCRIT.NE.JCLOSE) THEN
*       Form the return time of the dominant body and choose the minimum.
          DR = SQRT(RJMIN2) - RI*(BODY(JCLOSE)*A1)**0.3333
          DTMAX = SQRT(2.0D0*ABS(DR)/FMAX)
          DT = MIN(DT,DTMAX)
      END IF
*
*       Apply safety test in case background force dominates c.m. motion.
      DT = MIN(DT,4.0D0*STEP(I))
      DT = MAX(DT,0.0D0)
*
   20 RETURN
*
      END


! qmc_pi_lj.f90
! Quantum Monte Carlo, path-integral method
PROGRAM qmc_pi_lj

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! Takes in a set of configurations of atoms (positions)
  ! Cubic periodic boundary conditions
  ! Conducts path-integral Monte Carlo at the given temperature
  ! Uses no special neighbour lists

  ! Reads several variables and options from standard input using a namelist nml
  ! Leave namelist empty to accept supplied defaults

  ! Positions r are divided by box length after reading in
  ! However, input configuration, output configuration, most calculations, and all results
  ! are given in simulation units defined by the model
  ! For example, for Lennard-Jones, sigma = 1, epsilon = 1
  ! The importance of quantum effects is specified through the reduced de Boer length
  ! lambda = (hbar/sqrt(mass*epsilon))/sigma which takes typical values of
  ! 0.01 for Xe, 0.03 for Ar, and 0.095 for Ne.
  ! This means that the quantum spring constant may be expressed k_spring = P*(T/lambda)**2
  ! where T stands for the reduced temperature kB*T/epsilon

  ! Despite the program name, there is nothing here specific to Lennard-Jones
  ! The model is defined in qmc_module

  USE, INTRINSIC :: iso_fortran_env,  ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE               config_io_module, ONLY : read_cnf_atoms, write_cnf_atoms
  USE               averages_module,  ONLY : run_begin, run_end, blk_begin, blk_end, blk_add
  USE               maths_module,     ONLY : metropolis, random_translate_vector
  USE               qmc_module,       ONLY : introduction, conclusion, allocate_arrays, deallocate_arrays, &
       &                                     potential_1, spring_1, potential, spring, n, p, r, potential_type

  IMPLICIT NONE

  ! Most important variables
  REAL :: box         ! Box length
  REAL :: lambda      ! de Boer length
  REAL :: dr_max      ! Maximum MC displacement
  REAL :: dc_max      ! Maximum centre-of-mass MC displacement
  REAL :: temperature ! Specified temperature
  REAL :: r_cut       ! Potential cutoff distance

  ! Composite interaction = pot & ovr variables
  TYPE(potential_type) :: total, partial_old, partial_new

  INTEGER            :: blk, stp, i, k, km, kp, nstep, nblock, r_moves, c_moves, ioerr
  REAL               :: total_spr, partial_old_spr, partial_new_spr, delta, k_spring
  REAL               :: r_ratio, c_ratio
  REAL               :: rad_g
  REAL, DIMENSION(3) :: rik, dc

  CHARACTER(len=3), PARAMETER :: inp_tag    = 'inp'
  CHARACTER(len=3), PARAMETER :: out_tag    = 'out'
  CHARACTER(len=3)            :: sav_tag    = 'sav'    ! May be overwritten with block number
  CHARACTER(len=6)            :: cnf_prefix = 'cnf##.' ! Will have polymer id inserted
  CHARACTER(len=2)            :: k_tag                 ! Will contain polymer id

  NAMELIST /nml/ nblock, nstep, p, temperature, r_cut, dr_max, dc_max, lambda

  WRITE ( unit=output_unit, fmt='(a)' ) 'qmc_pi_lj'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Path-integral Monte Carlo, constant-NVT ensemble'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Simulation uses cut (but not shifted) potential'
  CALL introduction

  CALL RANDOM_SEED () ! Initialize random number generator

  ! Set sensible default run parameters for testing
  nblock      = 10
  nstep       = 10000
  temperature = 0.701087
  r_cut       = 2.5
  dr_max      = 0.05
  dc_max      = 0.1
  p           = 4
  lambda      = 0.092 ! from Ne parameters epsilon=36.8K, sigma=0.2789nm, m=20.18u

  ! Read run parameters from namelist
  ! Comment out, or replace, this section if you don't like namelists
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in qmc_pi_lj'
  END IF

  ! Write out run parameters
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Size of each ring polymer', p
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of blocks',          nblock
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps per block', nstep
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Temperature',               temperature
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Potential cutoff distance', r_cut
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Maximum displacement',      dr_max
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Maximum COM displacement',  dc_max
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'de Boer length',            lambda
  IF ( p < 2 .OR. p > 99 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'p must lie between 2 and 99', p
     STOP 'Error in qmc_pi_lj'
  END IF
  k_spring = REAL(p) * ( temperature / lambda ) ** 2
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Quantum spring constant', k_spring

  ! Read in initial configuration and allocate necessary arrays
  ! Read each polymer index from a unique file; we assume that n and box are all the same!
  cnf_prefix(4:5) = '01' ! Read first LJ configuration to get basic parameters n and box
  CALL read_cnf_atoms ( cnf_prefix//inp_tag, n, box )
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of particles',   n
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Simulation box length', box
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Density',               REAL(n) / box**3
  CALL allocate_arrays ( box, r_cut ) ! Allocate r
  DO k = 1, p ! Loop over ring polymer indices
     WRITE(k_tag,fmt='(i2.2)') k ! Convert into character form
     cnf_prefix(4:5) = k_tag     ! Insert into configuration filename
     CALL read_cnf_atoms ( cnf_prefix//inp_tag, n, box, r(:,:,k) ) ! Read r for polymer index k
  END DO ! End loop over ring polymer indices
  r(:,:,:) = r(:,:,:) / box                ! Convert all positions to box units
  r(:,:,:) = r(:,:,:) - ANINT ( r(:,:,:) ) ! Periodic boundaries (box=1 units)

  ! Calculate classical LJ and quantum spring potential energies & check overlap
  total = potential ( box, r_cut )
  IF ( total%ovr ) THEN
     WRITE ( unit=error_unit, fmt='(a)') 'Overlap in initial configuration'
     STOP 'Error in qmc_pi_lj'
  END IF
  total_spr = spring ( box, k_spring )

  ! Initialize arrays for averaging and write column headings
  r_ratio = 0.0
  c_ratio = 0.0
  CALL run_begin ( calc_variables() )

  DO blk = 1, nblock ! Begin loop over blocks

     CALL blk_begin

     DO stp = 1, nstep ! Begin loop over steps

        r_moves = 0
        c_moves = 0

        DO i = 1, n ! Begin loop over atoms

           ! Centre of mass move

           dc = 0.0
           dc = random_translate_vector ( dc_max/box, dc ) ! Random displacement
           partial_old = potential_type ( 0.0, 0.0, .FALSE. )
           partial_new = potential_type ( 0.0, 0.0, .FALSE. )
           DO k = 1, p ! Loop over ring polymer indices
              partial_old = partial_old + potential_1 ( r(:,i,k), i, k, box, r_cut ) ! Old atom classical potential etc
              rik(:) = r(:,i,k) + dc
              rik(:) = rik(:) - ANINT ( rik(:) )                                     ! Periodic boundary correction
              partial_new = partial_new + potential_1 ( rik, i, k, box, r_cut )      ! New atom classical potential etc
           END DO

           IF ( partial_old%ovr ) THEN ! should never happen
              WRITE ( unit=error_unit, fmt='(a)') 'Overlap in current configuration'
              STOP 'Error in qmc_pi_lj'
           END IF

           IF ( .NOT. partial_new%ovr ) THEN ! Test for non-overlapping configuration

              delta = partial_new%pot - partial_old%pot ! Change in classical cut (but not shifted) potential
              delta = delta / temperature               ! Divide by temperature

              IF ( metropolis ( delta ) ) THEN ! Accept Metropolis test
                 total     = total + partial_new - partial_old          ! Update classical total values
                 r(:,i,:)  = r(:,i,:) + SPREAD ( dc, dim=2, ncopies=p ) ! Update position
                 r(:,i,:)  = r(:,i,:) - ANINT ( r(:,i,:) )              ! Periodic boundary corrections
                 c_moves   = c_moves + 1                                ! Increment move counter
              END IF ! End accept Metropolis test

           END IF ! End test for non-overlapping configuration

           ! Individual atom moves

           DO k = 1, p ! Begin loop over ring polymer indices

              partial_old = potential_1 ( r(:,i,k), i, k, box, r_cut ) ! Old atom classical potential etc

              IF ( partial_old%ovr ) THEN ! should never happen
                 WRITE ( unit=error_unit, fmt='(a)') 'Overlap in current configuration'
                 STOP 'Error in qmc_pi_lj'
              END IF

              ! Get neighbour indices
              kp = k+1
              IF ( kp > p ) kp = 1
              km = k-1
              if ( km < 1 ) km = p
              partial_old_spr = spring_1 ( r(:,i,k), r(:,i,km), box, k_spring ) &
                   &          + spring_1 ( r(:,i,k), r(:,i,kp), box, k_spring ) ! Old atom quantum potential

              rik(:) = random_translate_vector ( dr_max/box, r(:,i,k) ) ! Trial move to new position (in box=1 units)
              rik(:) = rik(:) - ANINT ( rik(:) )                        ! Periodic boundary correction

              partial_new = potential_1 ( rik, i, k, box, r_cut ) ! New atom classical potential etc

              IF ( .NOT. partial_new%ovr ) THEN ! Test for non-overlapping configuration

                 partial_new_spr = spring_1 ( rik, r(:,i,km), box, k_spring ) &
                      &          + spring_1 ( rik, r(:,i,kp), box, k_spring ) ! New atom quantum potential

                 delta =         partial_new%pot - partial_old%pot ! Change in classical cut (but not shifted) potential
                 delta = delta + partial_new_spr - partial_old_spr ! Add change in quantum potential
                 delta = delta / temperature                       ! Divide by temperature

                 IF ( metropolis ( delta ) ) THEN ! Accept Metropolis test
                    total     = total     + partial_new     - partial_old     ! Update classical total values
                    total_spr = total_spr + partial_new_spr - partial_old_spr ! Update quantum system potential
                    r(:,i,k)  = rik                                           ! Update position
                    r_moves   = r_moves + 1                                   ! Increment move counter
                 END IF ! End accept Metropolis test

              END IF ! End test for non-overlapping configuration

           END DO ! End loop over ring polymer indices

        END DO ! End loop over atoms

        r_ratio = REAL(r_moves) / REAL(n*p)
        c_ratio = REAL(c_moves) / REAL(n)

        ! Calculate and accumulate variables for this step
        CALL blk_add ( calc_variables() )

     END DO ! End loop over steps

     CALL blk_end ( blk )                                                  ! Output block averages
     IF ( nblock < 1000 ) WRITE(sav_tag,fmt='(i3.3)') blk                  ! Number configuration by block
     DO k = 1, p ! Loop over ring polymer indices
        WRITE(k_tag,fmt='(i2.2)') k                                        ! Convert into character form
        cnf_prefix(4:5) = k_tag                                            ! Insert into configuration filename
        CALL write_cnf_atoms ( cnf_prefix//sav_tag, n, box, r(:,:,k)*box ) ! Save to unique file
     END DO ! End loop over ring polymer indices

  END DO ! End loop over blocks

  CALL run_end ( calc_variables() ) ! Output run averages

  ! Final double-check on book-keeping for totals, and overlap
  total = potential ( box, r_cut )
  IF ( total%ovr ) THEN ! should never happen
     WRITE ( unit=error_unit, fmt='(a)') 'Overlap in final configuration'
     STOP 'Error in qmc_pi_lj'
  END IF
  total_spr = spring ( box, k_spring )

  DO k = 1, p ! Loop over ring polymer indices
     WRITE(k_tag,fmt='(i2.2)') k                                        ! Convert into character form
     cnf_prefix(4:5) = k_tag                                            ! Insert into configuration filename
     CALL write_cnf_atoms ( cnf_prefix//out_tag, n, box, r(:,:,k)*box ) ! Write to unique file
  END DO ! End loop over ring polymer indices

  CALL deallocate_arrays
  CALL conclusion

CONTAINS

  FUNCTION calc_variables ( ) RESULT ( variables )
    USE lrc_module,      ONLY : potential_lrc, pressure_lrc
    USE averages_module, ONLY : variable_type
    IMPLICIT NONE
    TYPE(variable_type), DIMENSION(7) :: variables ! The 7 variables listed below

    ! This routine calculates all variables of interest and (optionally) writes them out
    ! They are collected together in the variables array, for use in the main program

    ! In this example we simulate using the cut (but not shifted) potential
    ! but we only report results which have had the long-range corrections applied
    ! The value of the cut-and-shifted potential is not used, in this example

    TYPE(variable_type) :: r_r, c_r, e_f, p_f, e_q, k_q, r_g
    REAL                :: vol, rho, kin, kin_q

    ! Preliminary calculations
    vol   = box**3                    ! Volume
    rho   = REAL(n) / vol             ! Density
    kin   = 1.5 * n * p * temperature ! Average kinetic energy for NP-atom system
    kin_q = kin - total_spr           ! Quantum estimator for kinetic energy
    rad_g = rad_gyr ( r )

    ! Variables of interest, of type variable_type, containing three components:
    !   %val: the instantaneous value
    !   %nam: used for headings
    !   %method: indicating averaging method
    ! If not set below, %method adopts its default value of avg
    ! The %nam and some other components need only be defined once, at the start of the program,
    ! but for clarity and readability we assign all the values together below

    ! Acceptance ratio of atomic moves
    r_r = variable_type ( nam = 'Atomic move ratio', val = r_ratio, instant = .FALSE. )

    ! Acceptance ratio of centre-of-mass moves
    c_r = variable_type ( nam = 'COM move ratio', val = c_ratio, instant = .FALSE. )

    ! Internal energy per atom for full potential with LRC
    ! LRC plus total (cut but not shifted) PE already divided by factor P
    ! plus KE estimator: total classical KE for NP-atom system MINUS total spring potential
    ! all divided by N
    e_f = variable_type ( nam = 'E/N full', val = potential_lrc(rho,r_cut) + (kin_q+total%pot)/REAL(n) )

    ! Kinetic energy per atom, just for interest's sake
    k_q = variable_type ( nam = 'KE/N', val = kin_q/REAL(n) )

    ! Pressure for full potential with LRC
    ! LRC plus ideal gas contribution plus total virial divided by V
    kin_q = kin_q / 1.5 ! Convert KE estimator to kinetic energy part of pressure
    p_f = variable_type ( nam = 'P full', val = pressure_lrc(rho,r_cut) + (kin_q+total%vir)/vol )

    ! Quantum spring energy per atom, just for interest's sake
    e_q = variable_type ( nam = 'Espring/N', val = total_spr/REAL(n) )

    ! Quantum polymer radius of gyration, just for interest's sake
    r_g = variable_type ( nam = 'Radius of gyration', val = rad_g )

    ! Collect together for averaging
    variables = [ r_r, c_r, e_f, p_f, e_q, k_q, r_g ]

  END FUNCTION calc_variables

  FUNCTION rad_gyr ( r ) RESULT ( r_g )
    IMPLICIT NONE
    REAL, DIMENSION(:,:,:), INTENT(in) :: r   ! Coordinate array
    REAL                               :: r_g ! RMS radius of gyration

    ! Calculate average radius of gyration of polymers
    ! The formula we use involves a single sweep over atoms, and is origin-independent
    ! To implement periodic boundaries, we take the origin on atom 1

    INTEGER            :: i, k
    REAL, DIMENSION(3) :: r_ik, r_cm
    REAL               :: r_sq

    r_g = 0.0 ! Zero function accumulator

    DO i = 1, n ! Loop over polymers
       r_cm = 0.0
       r_sq = 0.0
       DO k = 2, p ! Loop over atoms in polymer, omitting first one
          r_ik = r(:,i,k) - r(:,i,1) ! Position relative to atom 1
          r_ik = r_ik - ANINT(r_ik)  ! Position with PBC applied (box = 1 units)
          r_cm = r_cm + r_ik         ! Increment centre-of-mass accumulator
          r_sq = r_sq + SUM(r_ik**2) ! Increment squared distance accumulator
       END DO ! End loop over atoms in polymer, omitting first one
       r_cm = r_cm / REAL(p)      ! Normalize centre-of-mass vector
       r_sq = r_sq / REAL(p)      ! Normalize mean-squared distances
       r_sq = r_sq - SUM(r_cm**2) ! Definition of squared radius of gyration
       IF ( r_sq < 0.0 ) THEN
          WRITE(*,*) 'Warning! ', r_sq
          r_sq = 0.0
       END IF
       r_g = r_g + SQRT(r_sq)    ! Accumulate root-mean-square radius of gyration
    END DO ! End loop over polymers

    r_g = box * r_g / REAL(n) ! Average RMS Rg in sigma=1 units

  END FUNCTION rad_gyr

END PROGRAM qmc_pi_lj


      program prog
      integer base_size
      parameter(base_size=3)
      parameter(nums_size=base_size*2)
      common /com/ nums(nums_size)
      do i=1,nums_size
        nums(i) = 13 + i * 5
      enddo
      write(6, *) nums
      end


      SUBROUTINE simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1)
      INTEGER ip,kp,m,mp,n,nl2,np,l2(mp)
      REAL q1,a(mp,np),EPS
      PARAMETER (EPS=1.e-6)
      INTEGER i,ii,k
      REAL q,q0,qp
      ip=0
      do 11 i=1,nl2
        if(a(l2(i)+1,kp+1).lt.-EPS)goto 1
11    continue
      return
1     q1=-a(l2(i)+1,1)/a(l2(i)+1,kp+1)
      ip=l2(i)
      do 13 i=i+1,nl2
        ii=l2(i)
        if(a(ii+1,kp+1).lt.-EPS)then
          q=-a(ii+1,1)/a(ii+1,kp+1)
          if(q.lt.q1)then
            ip=ii
            q1=q
          else if (q.eq.q1) then
            do 12 k=1,n
              qp=-a(ip+1,k+1)/a(ip+1,kp+1)
              q0=-a(ii+1,k+1)/a(ii+1,kp+1)
              if(q0.ne.qp)goto 2
12          continue
2           if(q0.lt.qp)ip=ii
          endif
        endif
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/simp2.for


C    %W% %G%
      subroutine sect (k)
C * * *
C * * * THIS SUBROUTINE FORMS A SINGLE EQUIVALENT PI FOR A LINE
C * * * CONTAINING MULTIPLE PI SECTIONS.  IT IS CALLED BY
C * * * INPUT2.
C * * *
      include 'tspinc/blkcom1.inc'
      include 'tspinc/legspi.inc'

      go to (100,120,140), k
  100 gs1=gij+gj1
      gs2=-gij
      gs4=gij+gi1
      bs1=bij+bj1
      bs2=-bij
      bs4=bij+bi1
      go to 160
  120 gs1=gs1+gij+gi1
      gs3=-gij
      gs5=gij+gj1
      bs1=bs1+bij+bi1
      bs3=-bij
      bs5=bij+bj1
      sq=gs1*gs1+bs1*bs1
      pg=gs1/sq
      pb=-bs1/sq
      a1=pg*gs2-pb*bs2
      a2=pb*gs2+pg*bs2
      gs4=gs4-(a1*gs2-a2*bs2)
      bs4=bs4-(a2*gs2+a1*bs2)
      gs2=-(a1*gs3-a2*bs3)
      bs2=-(a2*gs3+a1*bs3)
      a1=pg*gs3-pb*bs3
      a2=pb*gs3+pg*bs3
      gs1=gs5-(a1*gs3-a2*bs3)
      bs1=bs5-(a2*gs3+a1*bs3)
      go to 160
  140 gi1=gs4+gs2
      bi1=bs4+bs2
      gj1=gs1+gs2
      bj1=bs1+bs2
      gij=-gs2
      bij=-bs2
  160 return
      end


c  a front end to several numerical recipes routines
c  for least square fitting - straight line, errors
c  in 0, 1, or 2 coords

c lstsq_bootstrap.f is copyright 2006 Benjamin Weiner and released under
c the GNU General Public License.  You may modify, you may redistribute,
c you must retain the copyright notice.  Please contact me with
c any comments and suggestions.

c See Weiner et al. 2006 (ApJ, in press, astro-ph/------)
c for a discussion of fitting lines to data with intrinsic scatter.

c 4/23/00 - modified to ignore input lines beginning with '#',
c   and to allow fitting only a given region

c 3/18/05 - added bootstrap estimation of the parameters/errors
c   by sampling with replacement and refitting

c 12/20/05 - allows adding the intrinsic scatter in quadrature.
c    following lstsq.f.  Note this is redundant with bootstrapping
c    for error estimation - once you have the correct intrinsic
c    scatter that makes chisq/N=1, the original fit should return
c    an error that is very close to the RMS of the bootstraps.
c    However, the bootstraps are still useful for looking at the
c    covariance of a and b.

c  8/30/06 - added the second plot of the distribution of a vs b
c    as fit to the bootstrap resamples.

c Benjamin Weiner, bjw at astro.umd.edu (Astronomy Dept, University
c of Maryland; Steward Observatory as of Sept 2006)

      program lstsq_bootstrap

      parameter(NMAX=100000)
c      parameter(NMAX_XY=1000)
      parameter(NMAX_XY=10000)
      parameter(NBOOTMAX=10000)

c      real x1(NMAX),x2(NMAX),x3(NMAX)x4(NMAX)
c      real x1err(NMAX),x2err(NMAX),x3err(NMAX)
      real x(NMAX), xerr(NMAX)
      real y(NMAX), yerr(NMAX)
      real xf(NMAX), xferr(NMAX)
      real yf(NMAX), yferr(NMAX)
      real xerrbot(NMAX),xerrtop(NMAX)
      real yerrbot(NMAX),yerrtop(NMAX)
      real xpl(2),ypl(2)

      real xftry(NMAX),yftry(NMAX),xftryerr(NMAX),yftryerr(NMAX)
      real aboot(NBOOTMAX),bboot(NBOOTMAX)

      character fname*40,dline*80

      big = 1.e20

      write(*,*) "0- plain least squares, 1- errors in y"
      write(*,'(" 2- errors in x and y, ",
     +     "3- x & y errors and y scatter: "$)')
c      write(*,'(" 3- y=y(x1,x2,...) : "$)')
      read(*,*) ichoose

c      if (ichoose .eq. 3) then
c         write(*,'("number of x'es [1-4]: "
c         read (*,*) nx
c      end if

 10   write (*,'("enter file: "$)')
      read (*,*) fname

      open (2,file=fname,status='old',err=10)
      npts = 1
 20   continue
         read (2,'(a)',end=30) dline
         if (dline(1:1) .eq. '#') go to 20
         if (ichoose .eq. 0) then
            xerr(npts) = 0.
            yerr(npts) = 0.
            read (dline,*,err=20) x(npts),y(npts)
         else if (ichoose .eq. 1) then
            xerr(npts) = 0.
            read (dline,*,err=20) x(npts),y(npts),yerr(npts)
         else if (ichoose .eq. 2 .or. ichoose .eq. 3) then
            read (dline,*,err=20) x(npts),xerr(npts),
     $           y(npts),yerr(npts)
         end if
         npts=npts+1
      go to 20

 30   npts = npts-1
      write(*,*) 'Read ', npts, ' points'
      close(2)
      if (npts .gt. NMAX) then
         write(*,*) "Currently dimensioned for only max ",NMAX," points"
      end if
      if (ichoose .ge. 2 .and. npts .gt. NMAX_XY) then
       write(*,*)
     +   "Fitting w/both X and Y error will not work for >",NMAX_XY
       write(*,*) "points without redimensioning arrays in fitexy.f and"
       write(*,*) "other Numerical Recipes subroutines: chixy.f."
      end if

c for ichoose = 3, add the scatter in quadrature to the error
c and then continue as if we were doing ichoose=2
      if (ichoose .eq. 3) then
         write(*,'("intrinsic scatter in y-coord: ",$)')
         read (*,*) yintscatt
         yintscattsq = yintscatt**2
         do i=1,npts
            yerr(i) = sqrt(yerr(i)**2 + yintscattsq)
         end do
         ichoose = 2
      end if

c  moved plotting points to here

c this is sloppy and works because the errors are 0 if
c they are not supplied

      xmin = big
      xmax = -big
      ymin = big
      ymax = -big
      do i=1,npts
         xerrbot(i) = x(i)-xerr(i)
         xerrtop(i) = x(i)+xerr(i)
         yerrbot(i) = y(i)-yerr(i)
         yerrtop(i) = y(i)+yerr(i)
         xmin = min(xmin,xerrbot(i))
         xmax = max(xmax,xerrtop(i))
         ymin = min(ymin,yerrbot(i))
         ymax = max(ymax,yerrtop(i))
      end do

      xmargin = 0.1*(xmax-xmin)
      ymargin = 0.1*(ymax-ymin)
      wxmin = xmin-xmargin
      wxmax = xmax+xmargin
      wymin = ymin-ymargin
      wymax = ymax+ymargin

      call pgbegin (0,"?",1,1)
      call pgask(.false.)
      call pgscf(2)
      call pgsch(1.1)

      call pgenv(wxmin,wxmax,wymin,wymax,0,1)
      call pglabel ("x","y","Least squares fit")
      call pgpoint (npts,x,y,17)
      if(ichoose .eq. 1 .or. ichoose .eq. 2) then
         call pgerrb(6,npts,x,y,yerr,1.0)
         if (ichoose .eq. 2) then
            call pgerrb(5,npts,x,y,xerr,1.0)
         end if
      end if

c  select fitting window
      xfmin = wxmin
      xfmax = wxmax
      write (*,'("Enter xmin, xmax to fit [use all]: ",$)')
      read (*,'(a)') dline
      if (dline(1:5) .ne. '     ') then
         read(dline,*,err=40) xfmin,xfmax
      end if
 40   continue

      nf = 0
      do i=1,npts
         if(x(i) .gt. xfmin .and. x(i) .lt. xfmax) then
            nf = nf+1
            xf(nf) = x(i)
            yf(nf) = y(i)
            xferr(nf) = xerr(i)
            yferr(nf) = yerr(i)
         end if
      end do
      write(*,*) "Including ",nf," points"
      if(nf .lt.2) go to 666

c  do fit

      if (ichoose .eq. 0) then
c         call fit(x,y,npts,yerr,0,a,b,siga,sigb,chisq,q)
         call fit(xf,yf,nf,yferr,0,a,b,siga,sigb,chisq,q)
      else if (ichoose .eq. 1) then
c         call fit(x,y,npts,yerr,1,a,b,siga,sigb,chisq,q)
         call fit(xf,yf,nf,yferr,1,a,b,siga,sigb,chisq,q)
      else if (ichoose .eq. 2) then
c         call fitexy(x,y,npts,xerr,yerr,a,b,siga,sigb,chisq,q)
c         call fitexy_big(xf,yf,nf,xferr,yferr,a,b,siga,sigb,chisq,q)
         call big_fitexy(xf,yf,nf,xferr,yferr,a,b,siga,sigb,chisq,q)
      end if

c  plot fit

      xpl(1) = wxmin
      ypl(1) = a + b*wxmin
      xpl(2) = wxmax
      ypl(2) = a + b*wxmax

      call pgline(2,xpl,ypl)

      write(*,*) 'y = a + bx'
      write(*,*) 'a = ',a,' +/- ',siga
      write(*,*) 'b = ',b,' +/- ',sigb
      write(*,*) 'chisq = ',chisq,' prob. = ',q

c save the best fit values
      abest = a
      bbest = b
      abesterr = siga
      bbesterr = sigb

      sumsqerr = 0.0
c      do i=1,npts
      do i=1,nf
         sumsqerr = sumsqerr + (y(i)-a-b*x(i))**2
      end do
c      write (*,*) 'rms error = ',sqrt(sumsqerr/npts)
      write (*,*) 'rms error = ',sqrt(sumsqerr/nf)

c  write data and fit to file

      open(3,file='lstsq.out',status='unknown')
      if (ichoose .eq. 0) then
         write (3,*) 'xdata       ydata       yfit'
         do i=1,npts
            write(3,*) x(i),y(i),a + b*x(i)
         end do
      else if (ichoose .eq. 1) then
         write (3,*) 'xdata       ydata        yerror       yfit'
         do i=1,npts
            write(3,*) x(i),y(i),yerr(i),a + b*x(i)
         end do
      else if (ichoose .eq. 2) then
         write (3,*)
     $        'xdata       xerror       ydata       yerror   yfit'
         do i=1,npts
            write(3,*) x(i),xerr(i),y(i),yerr(i),a + b*x(i)
         end do
      end if
      close(3)

c initialize random
      idum = -1
 200  continue
      write(*,'("Number of resamples for bootstrap: ",$)')
      read (*,*) nboot
      if (nboot .gt. NBOOTMAX) then
         write(*,*) "max samples ",NBOOTMAX," setting to that"
         nboot = NBOOTMAX
      end if

      asum = 0.0
      asumsq = 0.0
      bsum = 0.0
      bsumsq = 0.0
      amax = -1.e10
      amin =  1.e10
      bmax = -1.e10
      bmin =  1.e10
      open(3,file='lstsq_bootstrap.out',status='unknown')
c For nboot resamples
      do i=1,nboot
c         write(*,*) 'Doing resample ',i
c make random resample
         do j=1,nf
            jrand = int(nf*ran1(idum)) +1
            xftry(j) = xf(jrand)
            yftry(j) = yf(jrand)
            xftryerr(j) = xferr(jrand)
            yftryerr(j) = yferr(jrand)
         end do
c do fit
         if (ichoose .eq. 0) then
c            call fit(x,y,npts,yerr,0,a,b,siga,sigb,chisq,q)
            call fit(xftry,yftry,nf,yftryerr,0,a,b,siga,sigb,chisq,q)
         else if (ichoose .eq. 1) then
c            call fit(x,y,npts,yerr,1,a,b,siga,sigb,chisq,q)
            call fit(xftry,yftry,nf,yftryerr,1,a,b,siga,sigb,chisq,q)
         else if (ichoose .eq. 2) then
c            call fitexy(x,y,npts,xerr,yerr,a,b,siga,sigb,chisq,q)
c            call fitexy_big(xf,yf,nf,xferr,yferr,a,b,siga,sigb,chisq,q)
            call big_fitexy(xftry,yftry,nf,xftryerr,yftryerr,
     +           a,b,siga,sigb,chisq,q)
         end if
c record parameters
         aboot(i) = a
         bboot(i) = b
         asum = asum + a
         asumsq = asumsq + a*a
         bsum = bsum + b
         bsumsq = bsumsq + b*b
         write(3,*) i,a,b
         amax = max(amax,a)
         amin = min(amin,a)
         bmax = max(bmax,b)
         bmin = min(bmin,b)
      end do
      close(3)

c  compute mean and rms of parameters
      amean = asum /nboot
      arms = sqrt(asumsq/nboot - amean**2)
      bmean = bsum /nboot
      brms = sqrt(bsumsq/nboot - bmean**2)

c Plot the bootstrap realizations' values of a and b -
c useful for seeing covariance

      amarg = 0.2*(amax-amin)
      bmarg = 0.2*(bmax-bmin)
      call pgenv(amin-amarg,amax+amarg,bmin-bmarg,bmax+bmarg,0,1)
      call pglabel("a, intercept","b, slope",
     $     "y = a + bx, best fit and bootstrap realizations")
      call pgpoint(nboot,aboot,bboot,17)
c plot the original best fit point with the error bar from the
c rms of the bootstraps.  It might be better to use the 68% range,
c although they should be similar
      call pgsch(2.0)
      call pgsci(2)
      call pgpt1(abest,bbest,12)
      call pgerrb(5,1,abest,bbest,arms,1.0)
      call pgerrb(6,1,abest,bbest,brms,1.0)
      call pgsch(1.1)
      call pgsci(1)

c compute median and conf levels.  This sorts the aboot and bboot
c arrays so we need to do it last, after plotting and output.
      call sort(nboot,aboot)
      call sort(nboot,bboot)
      if (mod(nboot,2) .eq. 1) then
         indx = int(nboot/2) + 1
         amed = aboot(indx)
         bmed = bboot(indx)
      else
         indx=nboot/2
         amed = (aboot(indx) + aboot(indx+1))/2.0
         bmed = (bboot(indx) + bboot(indx+1))/2.0
      end if
      indx = nint(nboot*(0.5-0.34))
      a68lo = aboot(indx)
      b68lo = bboot(indx)
      indx = nint(nboot*(0.5+0.34))
      a68hi = aboot(indx)
      b68hi = bboot(indx)
      indx = nint(nboot*(0.5-0.477))
      a95lo = aboot(indx)
      b95lo = bboot(indx)
      indx = nint(nboot*(0.5+0.477))
      a95hi = aboot(indx)
      b95hi = bboot(indx)

      write(*,*) "Pars from bootstrap with ",nboot," resamples of ",
     +     nf," points"
      write(*,*) "mean, rms a = ",amean," +- ",arms
      write(*,*) "mean, rms b = ",bmean," +- ",brms

      write(*,*) "median and 68%, 95.4% ranges: "
      write(*,*) "a: ",amed,a68lo,a68hi,a95lo,a95hi
      write(*,*) "b: ",bmed,b68lo,b68hi,b95lo,b95hi

      write(*,*) "sigma estimates from 68% and 95%:"
      write(*,*) "a sigma: ",(a68hi-a68lo)/2.0,(a95hi-a95lo)/4.0
      write(*,*) "b sigma: ",(b68hi-b68lo)/2.0,(b95hi-b95lo)/4.0

 666  continue
      call pgend()

      end


      program bsncmp
c*********************************************************************
c
c     dl_poly utility program for comparing two BASIN files
c
c     copyright daresbury laboratory
c     author w.smith march 2008
c
c*********************************************************************

      implicit none

      integer, parameter:: mxatms=998

      character*8 name(mxatms)
      character*10 file0,file1
      integer i,lev0,lev1,imcon0,imcon1,natms
      real(8) disp,det,xxx,yyy,zzz,ddx,ddy,ddz,ddd,txx,tyy,tzz
      real(8) ccc(9),cel0(9),cel1(9),rcel0(9),rcel1(9)
      real(8) xx0(mxatms),yy0(mxatms),zz0(mxatms)
      real(8) xx1(mxatms),yy1(mxatms),zz1(mxatms)

      write(*,*)'Enter name of first basin file'
      read(*,*)file0
      write(*,*)'Enter name of second basin file'
      read(*,*)file1
      write(*,*)'Enter max allowed displacement'
      read(*,*)disp

c     open BASIN files

      open(7,file=file0)
      open(8,file=file1)

      read(7,*)
      read(7,*)lev0,imcon0,natms
      if(imcon0.gt.0)then
        read(7,*)cel0(1),cel0(2),cel0(3)
        read(7,*)cel0(4),cel0(5),cel0(6)
        read(7,*)cel0(7),cel0(8),cel0(9)
      endif
      call invert(cel0,rcel0,det)

      read(8,*)
      read(8,*)lev1,imcon1,natms
      if(imcon1.gt.0)then
        read(8,*)cel1(1),cel1(2),cel1(3)
        read(8,*)cel1(4),cel1(5),cel1(6)
        read(8,*)cel1(7),cel1(8),cel1(9)
      endif
      call invert(cel1,rcel1,det)

      do i=1,9
        ccc(i)=0.5d0*(cel0(i)+cel1(i))
      enddo

      do i=1,natms

        read(7,*,end=100)name(i)
        read(7,*)xxx,yyy,zzz
        xx0(i)=rcel0(1)*xxx+rcel0(4)*yyy+rcel0(7)*zzz
        yy0(i)=rcel0(2)*xxx+rcel0(5)*yyy+rcel0(8)*zzz
        zz0(i)=rcel0(3)*xxx+rcel0(6)*yyy+rcel0(9)*zzz

      enddo
  100 continue
      do i=1,natms

        read(8,*,end=200)name(i)
        read(8,*)xxx,yyy,zzz
        xx1(i)=rcel1(1)*xxx+rcel1(4)*yyy+rcel1(7)*zzz
        yy1(i)=rcel1(2)*xxx+rcel1(5)*yyy+rcel1(8)*zzz
        zz1(i)=rcel1(3)*xxx+rcel1(6)*yyy+rcel1(9)*zzz

      enddo
  200 continue

      write(*,*)'structural differences'

      do i=1,natms

        ddx=xx0(i)-xx1(i)
        ddy=yy0(i)-yy1(i)
        ddz=zz0(i)-zz1(i)
        txx=ddx-cel0(1)*nint(ddx/cel0(1))
        tyy=ddy-cel0(5)*nint(ddy/cel0(5))
        tzz=ddz-cel0(9)*nint(ddz/cel0(9))
        ddx=ccc(1)*txx+ccc(4)*tyy+ccc(7)*tzz
        ddy=ccc(2)*txx+ccc(5)*tyy+ccc(8)*tzz
        ddz=ccc(3)*txx+ccc(6)*tyy+ccc(9)*tzz
        ddd=ddx**2+ddy**2+ddz**2
        if(ddd.gt.disp**2)then
          write(*,'(a8,i10,3f16.8)')name(i),i,ddx,ddy,ddz
        endif

      enddo

      write(*,*)'Analysis complete'

      end
      subroutine invert(a,b,d)

c***********************************************************************
c
c     dl_poly subroutine to invert a 3 * 3 matrix using cofactors
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       april 1992
c
c***********************************************************************

      implicit none

      real(8) a,b,d,r

      dimension a(9),b(9)

c     calculate adjoint matrix
      b(1)=a(5)*a(9)-a(6)*a(8)
      b(2)=a(3)*a(8)-a(2)*a(9)
      b(3)=a(2)*a(6)-a(3)*a(5)
      b(4)=a(6)*a(7)-a(4)*a(9)
      b(5)=a(1)*a(9)-a(3)*a(7)
      b(6)=a(3)*a(4)-a(1)*a(6)
      b(7)=a(4)*a(8)-a(5)*a(7)
      b(8)=a(2)*a(7)-a(1)*a(8)
      b(9)=a(1)*a(5)-a(2)*a(4)

c     calculate determinant
      d=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
      r=0.d0
      if(abs(d).gt.0.d0)r=1.d0/d

c     complete inverse matrix
      b(1)=r*b(1)
      b(2)=r*b(2)
      b(3)=r*b(3)
      b(4)=r*b(4)
      b(5)=r*b(5)
      b(6)=r*b(6)
      b(7)=r*b(7)
      b(8)=r*b(8)
      b(9)=r*b(9)

      return
      end subroutine invert


      SUBROUTINE MATV(ITEST,CM,VI,VO)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION CM(3,3),VI(3),VO(3)
C
      IF(ITEST.NE.1) GO TO 10
C
      DO 5 I=1,3
      VO(I)=0.0D0
      DO 5 J=1,3
      VO(I)=VO(I)+CM(I,J)*VI(J)
    5 CONTINUE
C
      RETURN
C
   10 CONTINUE
C
      DO 15 I=1,3
      VO(I)=0.0D0
      DO 15 J=1,3
      VO(I)=VO(I)+CM(J,I)*VI(J)
   15 CONTINUE
C
      RETURN
C
      END


!
! subroutine PHASE_CODING_SL
!
! This routine receives all neuron phases and connections and
! updates (through function dJ_stdp) all connections weighs.
!
subroutine phase_coding_sl(N, M, sigma, matadj, phases)

  integer, intent(in)    :: N, M
  real(8), intent(inout) :: matadj(N, 0:M), sigma
  integer, intent(in)    :: phases(N)

  integer                :: tmax, to, dphi
  real(8)                :: weight, mbr, delta, dj

! Loop variables
  integer                :: ncon, j, p, l
  integer                :: contador

! Funcoes
  real(8)                :: ran1, dJ_stdp, STDP, getMeanBR

! Time for learning process
  tmax = int( 1d3 )

  write(*,*) '>> Rede aprendendo...'

  do j = 1, N

     ncon = int( matadj(j, 0) )
     write(*,*) 'Rodando para ', j

     do p = 1, ncon
        to = int( matadj(j, p) )
        weight = matadj(j, p) - dfloat(to)

        !matadj(j, p) = matadj(j, p) + dJ_stdp(weight, j, to, tmax, phases(j), phases(to))
        dj = dJ_stdp(weight, j, to, tmax, phases(j), phases(to))

        ! Verificando se pode passar de um!
        if ( dabs(dj) + sigma/3.60d0 .gt. 0.9 ) write(*,*) 'cacete de aguia!!'

        ! Atualizando o peso sinaptico
        matadj(j, p) = dfloat(to) + sigma/3.60d0 + dj

     enddo

  enddo

  write(*,*) '>> Atualizando mbr...'

  mbr = getMeanBR(N, M, matadj)
  delta = sigma - mbr
  write(*,*) 'Modified mbr: ', mbr, delta
  do j = 1, N

     ncon = int( matadj(j, 0) )

     do p = 1, ncon
        matadj(j, p) = matadj(j, p) + delta
     enddo

  enddo

  mbr = getMeanBR(N, M, matadj)
  write(*,*) 'Final mbr: ', mbr

  return
end subroutine phase_coding_sl

!
! function dJ_stdp
!
! This functions implements the phase-coding associative memory
! learning stage, in which the synaptic weight difference is
! evaluated.
!
real(8) function dJ_stdp(Jjp, j, p, tmax, phi1, phi2) result(dJ)

  integer, intent(in)    :: j, P, tmax, phi1, phi2
  real(8), intent(in)    :: Jjp

  ! Period
  integer                :: T

  ! Unity gauge
  real(8)                :: gauge

  ! Loop variables for convolution
  integer                :: k,l

  ! External functions
  real(8)                :: STDP, fdeterm

! Initial value of dJ
  dJ = 0.d0

! Setting the unity gauge
  gauge = 25.d0

! Period
  T = int( 10d1 )

  do k = 1, tmax
     do l = 1, tmax
        dJ = dJ + &
             fdeterm( k + phi1, T )*   &
             STDP( dfloat( k - l )  )* &
             fdeterm( l + phi2 , T )
     enddo
  enddo

  dJ = dJ/dfloat(tmax)*gauge

  return
end function dJ_stdp

!
! function FDETERM
!
! During the learning stage of the phase-code associative memory,
! this is the assumed activity of each neuron, given its specific
! phase.
!
real(8) function fdeterm(phi, T) result(f)

  integer, intent(in) :: T, phi

  if ( mod(phi, T) .eq. 0 ) then
     f = 1.d0
     return
  else
     f = 0.d0
     return
  endif

  return
end function fdeterm

!
! function STDP
!
! This function was tested and graph can be found in Textos.
!
real(8) function STDP(dt)

  real(8), intent(in) :: dt

  !Parameters
  real(8)             :: ap, ad, Tp, Td, gamma, eta

  ! Auxiliary variables
  real(8)             :: C

! Normalization condition
  C = 1./80.

! Values taken from Scarpetta et al EPL 2009
  Tp = 10.2d0
  Td = 28.6d0
  eta = 4.d0
  gamma = 42.d0

  ap = gamma*( 1.0/Tp + eta/Td )**(-1.)
  ad = gamma*( eta/Tp + 1.0/Td )**(-1.)

! Calculating the value
  if ( dt >= 0 ) then
     STPD = C*( ap*exp(-dt/Tp) - ad*exp(-eta*dt/Td) )
     return
  else
     STDP = C*( ap*exp(eta*dt/Tp) - ad*exp(dt/Td) )
     return
  end if

end function STDP


c Copyright notes
c Gnu Fortran Whetstone Double Precision Benchmark
c (c) Copyright 2002 - 2020 Anatoly S. Krivitsky, Ph.D.
c All rights reserved

c Conditional permission for free use of the code
c As soon as above copyright notes are mentioned,
c the author grants a permission to any person or organization
c to use, distribute and publish this code for free
c Questions and comments may be directed to the author at
c akrivitsky@yahoo.com and akrivitsky@gmail.com

c Disclaimer of Liability
c The user assumes all responsibility
c and risk for the use of this code "as is".
c There is no  warranty of any kind associated with the code.
c Under no circumstances, including negligence, shall the author be liable
c for any DIRECT, INDIRECT, INCIDENTAL, SPECIAL or CONSEQUENTIAL DAMAGES,
c or LOST PROFITS that result from the use or inability to use the code.
c Nor shall the author be liable for any such damages including,
c but not limited to, reliance by any person on any
c information obtained with the code

      INTEGER*4   j, k, l, i, isave
      INTEGER*4   n2, n3, n4, n6, n7, n8, n9, n11
      INTEGER*4   inner, outer, kount, npass, max_pass

      REAL*8      x, y, z, t1, t2, t3, e1(4)
      REAL*8      whet_save, dif_save, kilowhet
      REAL*8      begin_time, end_time, dif_time
      REAL*8      error, whet_err, percent_err
      REAL*8      secnds

      COMMON      t1, t2, t3, e1, j, k, l

      npass    =    0
      max_pass =    2

      WRITE (*,9000)
      READ  (*,*) inner
      WRITE (*,9100)
      READ  (*,*) outer

      DO WHILE( npass .LT. max_pass)
         WRITE (*,9200) npass + 1, outer, inner
         WRITE (*,*) ('=', j = 1, 60)
         kount      = 0
         begin_time = dble(secndsmy())

         DO WHILE( kount .LT. outer )

            t1 = 0.499975D00
            t2 = 0.50025D00
            t3 = 2.0D00

            isave = inner
            n2    = 12  * inner
            n3    = 14  * inner
            n4    = 345 * inner
            n6    = 210 * inner
            n7    = 32  * inner
            n8    = 899 * inner
            n9    = 616 * inner
            n11   = 93  * inner

            e1(1) =  1.0D00
            e1(2) = -1.0D00
            e1(3) = -1.0D00
            e1(4) = -1.0D00

            DO i = 1, n2
               e1(1) = ( e1(1) + e1(2) + e1(3) - e1(4)) * t1
               e1(2) = ( e1(1) + e1(2) - e1(3) + e1(4)) * t1
               e1(3) = ( e1(1) - e1(2) + e1(3) + e1(4)) * t1
               e1(4) = (-e1(1) + e1(2) + e1(3) + e1(4)) * t1
            END DO

            DO i = 1, n3
               CALL sub1( e1 )
            END DO

            j = 1
            DO i = 1, n4
               IF( j - 1 ) 20, 10, 20
   10          j = 2
               GOTO 30
   20          j = 3
   30          IF( j - 2 ) 50, 50, 40
   40          j = 0
               GOTO 60
   50          j = 1
   60          IF( j - 1 ) 70, 80, 80
   70          j = 1
               GOTO 100
   80          j = 0
  100       END DO

            j = 1
            k = 2
            l = 3
            DO i = 1, n6
               j = j * (k - j) * (l - k)
               k = l * k - (l - j) * k
               l = (l - k) * (k + j)
               e1(l - 1) = j + k + l
               e1(k - 1) = j * k * l
            END DO

            x = 0.5D00
            y = 0.5D00
            DO i = 1, n7
               x = t1 * DATAN( t3 * DSIN( x ) * DCOS( x ) /
     +             (DCOS( x + y ) + DCOS( x - y ) - 1.0D00) )
               y = t1 * DATAN( t3 * DSIN( y ) * DCOS( y ) /
     +             (DCOS( x + y ) + DCOS( x - y ) - 1.0D00) )
            END DO

            x = 1.0D00
            y = 1.0D00
            z = 1.0D00
            DO i = 1, n8
               CALL sub2( x, y, z )
            END DO

            j = 1
            k = 2
            l = 3
            e1(1) = 1.0D00
            e1(2) = 2.0D00
            e1(3) = 3.0D00
            DO i = 1, n9
               CALL sub3
            END DO

            x = 0.75D00
            DO i = 1, n11
               x = DSQRT( DEXP( DLOG( x ) / t2 ) )
            END DO

            inner = isave
            kount = kount + 1
         END DO

         end_time = secndsmy()
         dif_time = end_time - begin_time

         kilowhet = 100.0D+00 * DBLE( outer * inner ) / dif_time

         WRITE (*,9300) dif_time, kilowhet

         npass = npass + 1
         IF( npass .LT. max_pass ) THEN
            dif_save  = dif_time
            whet_save = kilowhet
            inner     = inner * max_pass
         ENDIF
      END DO

      error       =   dif_time - (dif_save * max_pass )
      whet_err    =   whet_save - kilowhet
      percent_err =   whet_err * 100.0D+00 / kilowhet
      WRITE (*,*)
      WRITE (*,*)
      WRITE (*,*) ('=', j = 1, 60)
      WRITE (*,9400) error, whet_err, percent_err
      IF( dif_time .LT. 10.0D00 )
     +   WRITE (*,*) 'TIME is less than 10 seconds -- ',
     +               'suggest larger inner loop'

 9000 FORMAT( '0Number of inner loops (suggest more than 3):  '  )
 9100 FORMAT( ' Number of outer loops (suggest more than 1):  '  )
 9200 FORMAT( ' Pass #', I3.2, ': ', I10, ' outer loop(s),', I10,
     +           ' inner loop(s)' )
 9300 FORMAT( ' Elapsed time =', E12.2, ' seconds' ,
     +        ' Whetstones   =', E12.2,
     +        ' double-precision kilowhets/second' )
 9400 FORMAT( ' Time error   =', E12.2, ' seconds' ,
     +        ' Whet error   =', E12.2, ' kwhets/sec' ,
     +        ' %    error   =', E12.2, ' % whet error' )

      END

      SUBROUTINE sub1( e )

      REAL*8 t1, t2, t3, e(4)
      COMMON t1, t2, t3

      DO i = 1, 6
         e(1) = (e(1)  + e(2) + e(3) - e(4)) * t1
         e(2) = (e(1)  + e(2) - e(3) + e(4)) * t1
         e(3) = (e(1)  - e(2) + e(3) + e(4)) * t1
         e(4) = (-e(1) + e(2) + e(3) + e(4)) / t3
      END DO
      RETURN
      END

      SUBROUTINE sub2( x, y, z )

      REAL*8 t1, t2, t3, x1, y1, x, y, z
      COMMON t1, t2, t3

      x1 = x
      y1 = y
      x1 = (x1 + y1) * t1
      y1 = (x1 + y1) * t1
      z  = (x1 + y1) / t3
      RETURN
      END

      SUBROUTINE sub3

      REAL*8 t1, t2, t3, e1(4)
      COMMON t1, t2, t3, e1, j, k, l

      e1(j) = e1(k)
      e1(k) = e1(l)
      e1(l) = e1(j)
      RETURN
      END

      FUNCTION  secndsmy()

cc      INTEGER*2 hour, minute, second, hundredth
      Real Seconds
      real *8 aux
      CALL CPU_Time(Seconds)

c      aux=dble(Seconds)
      secndsmy= Seconds
c      write (*,5000) aux
c 5000 format (1x, 'current time in seconds = ', g25.11)
c     CALL GETTIM( hour, minute, second, hundredth )
c     secnds = ((DBLE( hour ) * 3600.0) + (DBLE( minute) * 60.0) +
c    +           DBLE( second) + (DBLE( hundredth ) / 100.0))
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine error(u, errnm, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   compute the solution error
c
c---------------------------------------------------------------------

      implicit none

      integer nx, nxmax, ny, nz
      double precision u(5,nxmax,ny,nz), errnm(5)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  tmp
      double precision  u000ijk(5)
      double precision  errnm_cap(5)

      do m = 1, 5
         errnm(m) = 0.0d0
      end do

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(errnm_cap,tmp,m,u000ijk,i,j,k)
!$OMP&  SHARED(nx,ny,nz)
      do m=1,5
         errnm_cap(m)=0.0d0
      enddo
      do k = 2, nz-1
!$OMP DO SCHEDULE(STATIC)
         do j = 2, ny-1
            do i = 2, nx-1
               call exact( i, j, k, u000ijk, nx, ny, nz )
               do m = 1, 5
                  tmp = ( u000ijk(m) - u(m,i,j,k) )
                  errnm_cap(m) = errnm_cap(m) + tmp ** 2
               end do
            end do
         end do
!$OMP END DO nowait
      end do
      do m=1,5
!$OMP ATOMIC
         errnm(m)=errnm(m)+errnm_cap(m)
      enddo
!$OMP END PARALLEL

      do m = 1, 5
         errnm(m) = dsqrt(errnm(m) / (dble(nz-2)*dble(ny-2)*dble(nx-2)))
      end do

      return
      end


module precision
  integer, parameter :: rk = selected_real_kind(8)
  integer, parameter :: ik = selected_real_kind(4)
end module


program main

!*****************************************************************************80
!
!! MAIN is the main program for SOBOL_PRB.
!
!  Discussion:
!
!    SOBOL_PRB tests the SOBOL library.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 January 2010
!
!  Author:
!
!    John Burkardt

implicit real (kind = 8)(a-h, o-z)

  integer ( kind = 8 ), parameter :: ndim = 4

  integer ( kind = 8 ) dim_num
  integer ( kind = 8 ), dimension ( 3 ) :: dim_num_test = (/ 100, 500, 1000 /)
  integer ( kind = 8 ) i
  real ( kind = 8 ), allocatable, dimension ( : ) :: r
  integer ( kind = 8 ), dimension(ndim) ::  seed
  integer ( kind = 8 ) seed_in
  integer ( kind = 8 ) seed_out
  integer ( kind = 8 ) test
      real*8 gasdev
      real*8, dimension(ndim) :: q,x

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST13'
  write ( *, '(a)' ) '  I8_SOBOL computes the next element of a Sobol sequence.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  In this test, we get a few samples at high dimension.'
  write ( *, '(a)' ) '  We only print the first and last 2 entries of each'
  write ( *, '(a)' ) '  sample.'

    dim_num = 2

      open(100, file = 'random.dat')

    write ( *, '(a)' ) ' '
    write ( *, '(a,i8)' ) '  Using dimension    ', ndim

    seed = (/1,2,3,4/)

      seed_in = 0

      pi = 4.0*atan(1.0)

!      ns = 100000 ! sampling points

      print *, 'how many sampling points you want?'
      read(5,*) ns

      z0 = 0d0
      q = (/0d0,0d0,0d0,0d0/)

      anm = (1d0/2d0/pi)**2

    do i = 0, ns

!      do j=1,ndim
!        x(j) = gasdev(seed_in) + q(j)
!      enddo

      call i8_sobol(ndim, seed_in, x)
      x = 12.0*(x-0.5d0)

      z0 = z0 + x(1)**2*x(2)**2*exp(-x(1)**2/2.0-x(2)**2/2d0-x(3)**2/2d0-x(4)**2/2d0)
    enddo

    write ( 6, * )  'integration  = ', z0*anm/dble(ns)*12.0**4

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

1000 format(2(f14.6,1x))
  stop
end


!**********************************************************************
!    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 eastwest
!
        use pdata
        implicit none
!
!     everything private by default
!
      private
      public :: dsendeast,drcvwest,dsendwest,drcveast
      public :: ssendeast,srcvwest,ssendwest,srcveast
      public :: csendeast,crcvwest,csendwest,crcveast
      public :: zsendeast,zrcvwest,zsendwest,zrcveast

!
! private data to be used with the intenal routines
!

      integer :: number_of_rows, block
      integer :: east_proc, west_proc, number_of_blocks
      integer :: last_block, start_block,end_block
      integer :: pcol_owning_last_block

!  source code for the generic routines:
!     sendeastborder, sendwestborder, rcveastborder, rcvwestborder
!
!  This module contains routines to send and receive the right and left
!  most columns of each local block to the processor logically directly right
!  or left 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     |
!  |                  |             |             |             |
!  |------------------------------------------------------------|
!
!   sendeast executed on processor (0,0) will create a
!   send array containing two columns as follows:
!     row 1: the last columns of blocks A1, C1 and E1
!     row 2: the last columns of blocks A3, C3 and E3
!   this matrix will be then sent to  processor (0,1)
!
!   sendeast executed on processor (1,1) will create a
!   send array containing two columns as follows:
!     row 1: a column of zeros
!     row 2: the last columns of blocks B2 and D2
!
!
!   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,rcv_buffer)
!    subroutine rcvwestborder(a,desca,rcv_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 dsendwest(a,desca,send_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
! check for quick return, no transfer if only a single processor column
!

      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols - 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!
      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+west_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!
      do block = 1, last_block
      if( westmost(mycol,desca) ) then
        if( .not. east_most_block(block,mycol,desca)) then
          if( .not. east_most_block(block,west_proc,desca)) then
            send_buffer(1:size(a,1),block)=a(:,block*desca(NB_)+1)
          else
            send_buffer(1:size(a,1),block)=0
          endif
        endif
      else
        if( .not. east_most_block(block,west_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_)+1)
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call dgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,west_proc)

      return
      end subroutine dsendwest

      subroutine drcveast(a,desca,rcv_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)

!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from east processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!

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

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

      return
      endif

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod(1 + mycol, npcols)

!
!  receive the eastern border column from the east processor
!

      call dgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,east_proc)

      return
      end subroutine drcveast

      subroutine dsendeast(a,desca,send_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
!  check for quick return
!
      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod( 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+east_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!

      do block = 1, last_block
      if( eastmost(mycol,desca) ) then
        if( .not. west_most_block(block,east_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      else
        if( .not. east_most_block(block,mycol,desca)) then
          send_buffer(1:size(a,1),block)=a(:,block*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call dgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,east_proc)

      return
      end subroutine dsendeast

      subroutine drcvwest(a,desca,rcv_buffer)

      real(long_t), intent(in)  :: a(:,:)
      real(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from west processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!
      if (npcols .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(1:size(a,1),1) = 0
        else
          rcv_buffer(1:size(a,1),block) = a(:,(block-1)*desca(NB_))
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols -1 + mycol, npcols)

!
!  get the western border column from the western processors
!

      call dgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,west_proc)

      return
      end subroutine drcvwest

      subroutine ssendwest(a,desca,send_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
! check for quick return, no transfer if only a single processor column
!

      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols - 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!
      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+west_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!
      do block = 1, last_block
      if( westmost(mycol,desca) ) then
        if( .not. east_most_block(block,mycol,desca)) then
          if( .not. east_most_block(block,west_proc,desca)) then
            send_buffer(1:size(a,1),block)=a(:,block*desca(NB_)+1)
          else
            send_buffer(1:size(a,1),block)=0
          endif
        endif
      else
        if( .not. east_most_block(block,west_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_)+1)
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call sgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,west_proc)

      return
      end subroutine ssendwest

      subroutine srcveast(a,desca,rcv_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)

!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from east processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!

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

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

      return
      endif

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod(1 + mycol, npcols)

!
!  receive the eastern border column from the east processor
!

      call sgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,east_proc)

      return
      end subroutine srcveast

      subroutine ssendeast(a,desca,send_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
!  check for quick return
!
      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod( 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+east_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!

      do block = 1, last_block
      if( eastmost(mycol,desca) ) then
        if( .not. west_most_block(block,east_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      else
        if( .not. east_most_block(block,mycol,desca)) then
          send_buffer(1:size(a,1),block)=a(:,block*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call sgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,east_proc)

      return
      end subroutine ssendeast

      subroutine srcvwest(a,desca,rcv_buffer)

      real(short_t), intent(in)  :: a(:,:)
      real(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from west processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!
      if (npcols .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(1:size(a,1),1) = 0
        else
          rcv_buffer(1:size(a,1),block) = a(:,(block-1)*desca(NB_))
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols -1 + mycol, npcols)

!
!  get the western border column from the western processors
!

      call sgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,west_proc)

      return
      end subroutine srcvwest

      subroutine csendwest(a,desca,send_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
! check for quick return, no transfer if only a single processor column
!

      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols - 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!
      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+west_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!
      do block = 1, last_block
      if( westmost(mycol,desca) ) then
        if( .not. east_most_block(block,mycol,desca)) then
          if( .not. east_most_block(block,west_proc,desca)) then
            send_buffer(1:size(a,1),block)=a(:,block*desca(NB_)+1)
          else
            send_buffer(1:size(a,1),block)=0
          endif
        endif
      else
        if( .not. east_most_block(block,west_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_)+1)
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call cgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,west_proc)

      return
      end subroutine csendwest

      subroutine crcveast(a,desca,rcv_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)

!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from east processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!

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

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

      return
      endif

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod(1 + mycol, npcols)

!
!  receive the eastern border column from the east processor
!

      call cgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,east_proc)

      return
      end subroutine crcveast

      subroutine csendeast(a,desca,send_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
!  check for quick return
!
      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod( 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+east_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!

      do block = 1, last_block
      if( eastmost(mycol,desca) ) then
        if( .not. west_most_block(block,east_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      else
        if( .not. east_most_block(block,mycol,desca)) then
          send_buffer(1:size(a,1),block)=a(:,block*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call cgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,east_proc)

      return
      end subroutine csendeast

      subroutine crcvwest(a,desca,rcv_buffer)

      complex(short_t), intent(in)  :: a(:,:)
      complex(short_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from west processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!
      if (npcols .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(1:size(a,1),1) = 0
        else
          rcv_buffer(1:size(a,1),block) = a(:,(block-1)*desca(NB_))
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols -1 + mycol, npcols)

!
!  get the western border column from the western processors
!

      call cgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,west_proc)

      return
      end subroutine crcvwest
      subroutine zsendwest(a,desca,send_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
! check for quick return, no transfer if only a single processor column
!

      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols - 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!
      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+west_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!
      do block = 1, last_block
      if( westmost(mycol,desca) ) then
        if( .not. east_most_block(block,mycol,desca)) then
          if( .not. east_most_block(block,west_proc,desca)) then
            send_buffer(1:size(a,1),block)=a(:,block*desca(NB_)+1)
          else
            send_buffer(1:size(a,1),block)=0
          endif
        endif
      else
        if( .not. east_most_block(block,west_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_)+1)
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call zgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,west_proc)

      return
      end subroutine zsendwest

      subroutine zrcveast(a,desca,rcv_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)

!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from east processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!

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

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

      return
      endif

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod(1 + mycol, npcols)

!
!  receive the eastern border column from the east processor
!

      call zgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,east_proc)

      return
      end subroutine zrcveast

      subroutine zsendeast(a,desca,send_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(inout)  :: send_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       send_buffer: array containing a send buffer, with
!                    at least as many rows a the array a and
!                    a many columns as the number of local blocks
!                    of a on receiving processes
!

!
!  check for quick return
!
      if (npcols .eq. 1)  return

!
!  determine where my rows is and which row is east of me
!
      east_proc = mod( 1 + mycol, npcols)

!
!  determine the number of blocks on the west processor and
!  the the process owning the last block of the matrix a
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      pcol_owning_last_block =                                             &
     &      mod(number_of_blocks-1+npcols-desca(CSRC_),npcols)

      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+east_proc,npcols))/npcols

!
!  check to see if send buffer is big enough
!

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

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

!
!  loop over all blocks copying the appropriate column to send buffer
!

      do block = 1, last_block
      if( eastmost(mycol,desca) ) then
        if( .not. west_most_block(block,east_proc,desca)) then
          send_buffer(1:size(a,1),block)=a(:,(block-1)*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      else
        if( .not. east_most_block(block,mycol,desca)) then
          send_buffer(1:size(a,1),block)=a(:,block*desca(NB_))
        else
          send_buffer(1:size(a,1),block)=0
        endif
      endif
      enddo

!
!  send the buffer to the east processor
!
      call zgesd2d(icontext,size(a,1),last_block,                            &
     &             send_buffer,size(send_buffer,1),                          &
     &               myrow,east_proc)

      return
      end subroutine zsendeast

      subroutine zrcvwest(a,desca,rcv_buffer)

      complex(long_t), intent(in)  :: a(:,:)
      complex(long_t), intent(out) :: rcv_buffer(:,:)
      integer,      intent(in)  :: desca(:)
!
!  arguments
!       a: array contain the border columns to be sent
!       desca: array descriptor associated with a
!       rcv_buffer:  array containing the buffer with
!                    columns from west processor, returned to
!                    user.
!

!
!  calculate the number of local blocks and make sure
!  receive buffer is big enough to hold the data
!

      number_of_blocks = (desca(N_)+desca(NB_) -1)/desca(NB_)
      last_block = (number_of_blocks + npcols -1 -                         &
     &      mod(npcols-desca(CSRC_)+mycol,npcols))/npcols

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

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

!
!  if we only have a single column of processor, copy the data
!
      if (npcols .eq. 1)   then  ! copy from other portions of the array

       do block = 1, last_block
        if( block .eq. 1) then
          rcv_buffer(1:size(a,1),1) = 0
        else
          rcv_buffer(1:size(a,1),block) = a(:,(block-1)*desca(NB_))
        endif
       enddo

      return
      endif

!
!  determine where my rows is and which row is west of me
!
      west_proc = mod(npcols -1 + mycol, npcols)

!
!  get the western border column from the western processors
!

      call zgerv2d(icontext,size(a,1),last_block,                            &
     &             rcv_buffer,size(rcv_buffer,1),                            &
     &               myrow,west_proc)

      return
      end subroutine zrcvwest

C========================

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

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

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

        logical function eastmost(proc,desc)
         implicit none
         integer, intent(in) :: proc
         integer, intent(in) :: desc(:)
         eastmost = .false.
         if(mod(desc(CSRC_)-1+npcols,npcols).eq.proc)eastmost=.true.
         return
        end function eastmost
      end module eastwest


      subroutine PROBINIT (init,name,namlen,problo,probhi)

      use probdata_module
      implicit none

      integer init, namlen
      integer name(namlen)
      double precision problo(2), probhi(2)

      integer untin,i

      namelist /fortin/ probtype,specerr,specgrad,max_specerr_lev,max_specgrad_lev,&
                        diff_coeff

!
!     Build "probin" filename -- the name of file containing fortin namelist.
!
      integer maxlen
      parameter (maxlen=256)
      character probin*(maxlen)

      if (namlen .gt. maxlen) then
         write(6,*) 'probin file name too long'
         stop
      end if

      do i = 1, namlen
         probin(i:i) = char(name(i))
      end do

!     Read namelists
      untin = 9
      open(untin,file=probin(1:namlen),form='formatted',status='old')
      read(untin,fortin)
      close(unit=untin)

      end

      subroutine setregionnum(id,id_l1,id_l2,id_h1,id_h2,lo,hi,dx,plo)

      use probdata_module
      implicit none

      integer lo(2), hi(2)
      integer id_l1,id_l2,id_h1,id_h2
      double precision dx(2), plo(2)
      integer id(id_l1:id_h1,id_l2:id_h2)

      integer          :: i,j
      double precision :: x,y

      do j = lo(2), hi(2)
         do i = lo(1), hi(1)

             x = plo(1) + (i-lo(1)+0.5d0)*dx(1)
             y = plo(2) + (j-lo(2)+0.5d0)*dx(2)

             if (x.ge.0.25d0 .and. x.le.0.75d0 .and. y.ge.0.25d0 .and. y.le.0.75d0) then
                id(i,j) = 1
             else
                id(i,j) = 2
             endif
         enddo
      enddo

      end subroutine setregionnum