C***************************************************************************
C
C    PIXGRAD calculates the magnitude of the gradient of an image.
C    The original comments (below) are wrong; the default calculation
C    computes delta_x and delta_y by the following algorithm using a
C    3 x 3 pixel window around point e:
C
C          a   b  c             METHOD #1 (default):
C          d   e  f         delta_x(e) =  (f - d)/ 2
C          g   h  j         delta_y(e) =  (b - h)/ 2
C
C    The new parameter METHOD allows for more precise computations
C    using the following:
C
C      First-order ERDAS method:
C
C           delta_x = [(c + f + j) - (a + d + g)] / 6
C           delta_y = [(g + h + j) - (a + b + c)] / 6
C
C      Second-order ARCINFO method:
C
C           delta_x = [(c + 2*f + j) - (a + 2*d + g)] / 8
C           delta_y = [(g + 2*h + j) - (a + 2*b + c)] / 8
C
C     From the deltas the "dip" angle of the normal vector, and its
C     azimuthal orientation with respect to north  is computed by:
C
C          z = sqrt ( (delta_x**2) + (delta_y**2) )
C
C          dip angle =  ATAN(SQRT(z))
C          azimuth   =  ATAN2(-delta_x, delta_4) MOD 2*PI
C
C
C  Here is the original comment:
C
C    PIXGRAD calculates the magnitude of the gradiend of a picture.
C    The absolute value of the difference between the current pixel
C    and its eight adjacent neighbors is calculated.  For the current
C    output pixel location, the largest difference is produced on the
C    primary ourput data set; the secondary output data set will
C    contain the index of the largest difference.  The differences
C    are labelled 1 through 8 counterclockwise starting with the
C    difference of the current pixel (I,J) and the neighbor on the
C    left (I,J-1).
C
C    VARIABLE INP
C             Input filename - may be byte of halfword.
C    VARIABLE OUT
C             Output filenames - one for dip and the
C             other for azimuth. Byte data output.
C             Optionally, the user may have an output
C             centered data set and the X,Y derivatives
C             data set.  The centered data set, if present,
C             is output file 3; the X,Y data set follow.
C    VARIABLE SIZE
C             Vicar size field.
C             -----------------
C             Starting line          default - input image
C             Starting sample
C             Number of lines
C             Number of samples
C    VARIABLE FORMAT
C
C     The format is obtained from the input image label.
C     Also, it is used to determine the output format for the
C     x and y derivative files.  Default is REAL.
C
C    VARIABLE NORTH
C             Direction of North in degrees clockwise from
C                           top of image.
C             Default = 0.0
C    VARIABLE ADIP
C             Scale factor for slope.
C             DN(DIP) = ADIP * (DIP+BDIP)
C             where
C             adip - scale factor
C             dip  - computed dip in degrees
C             bdip - offset factor ( see BDIP )
C             Default = 255./90.
C    VARIABLE BDIP
C             Offset factor for slope.
C             DN(DIP) = ADIP * (DIP+BDIP)
C             where
C             adip - scale factor ( see ADIP )
C             dip  - computed dip in degrees
C             bdip - offset factor
C             Default = 0.0
C    VARIABLE AAZ
C             Scale factor for azimuth.
C             DN(AZIM) = AAZ * (AZIMUTH+BAZ)
C             where
C             aaz      - scale factor
C             azimuth  - computed azimuth in degrees from North
C             baz      - offset factor ( see BAZ )
C             Default = 256./360.
C    VARIABLE BAZ
C             Offset factor for azimuth.
C             DN(AZIM) = AAZ * (AZIMUTH+BAZ)
C             where
C             aaz      - scale factor ( see AAZ )
C             azimuth  - computed azimuth in degrees from North
C             baz      - offset factor
C             Default = 0.0
C    VARIABLE AXDER
C             Scale factor for xderivative.
C             DN(XDER) = AXDER * (XDERIV+BXDER)
C             where
C             axder    - scale factor
C             xderiv   - computed x derivative
C             bxder    - offset factor ( see BXDER )
C             Default = 256./360.
C    VARIABLE BXDER
C             Offset factor for x derivative.
C             DN(XDER) = AXDER * (XDERIV+BXDER)
C             where
C             axder    - scale factor ( see AXDER )
C             xderiv   - computed x derivative
C             bxder    - offset factor
C             Default = 256./360.
C    VARIABLE AYDER
C             Scale factor for y derivative.
C             DN(XDER) = AYDER * (YDERIV+BYDER)
C             where
C             ayder    - scale factor
C             yderiv   - computed y derivative
C             byder    - offset factor ( see BYDER )
C             Default = 256./360.
C    VARIABLE BYDER
C             Offset factor for x derivative.
C             DN(YDER) = AYDER * (YDERIV+BYDER)
C             where
C             ayder    - scale factor ( see AYDER )
C             yderiv   - computed x derivative
C             byder     - offset factor
C             Default = 256./360.
C    VARIABLE LSCALE
C             Line scale in miles per line.
C             Default = 0.01
C    VARIABLE SSCALE
C             Sample scale in miles per sample.
C             Default = 0.01
C    VARIABLE AALT
C             Altitude scale in feet per dn of input.
C             Default = 1.0 ft/dn
C    VARIABLE CENTERED
C             If centered output is required.
C***************************************************************************
C
C     10-10-88  ...SP...   CHANGED TO IGNORE FORMAT PARAMETER BECAUSE VICAR2
C                          USES ONLY THE FORMAT IN LABEL.
C     08-05-94   (CRI)     MSTP S/W Conversion (VICAR porting)
C     09-06-96    NDR      Added ARCINFO,ERDAS options, buffer sized 32000
C     10-10-96    BAM      1. added optional outputs for x and y derivarives
C                          2. added optional output for centered data set
C     01-08-97    NDR      Fixed ARCINFO,ERDAS horizontal sign-error bug
C     02-07-97    BAM      merged REA pdf changes into pdf
C
C
C    A = INPUT PICTURE (EG ALTITUDE)  HALFWORD OR BYTE
C    B = GRADIENT MAGNITUDE PICTURE (EG DIP)      BYTE ONLY
C    C = GRADIENT DIRECTION PICTURE (EGAZIMUTH)   BYTE ONLY
C
C    SIZE FIELD REFERS TO THE INPUT PICTURE
C
C    PARAMETERS ARE POSITIONALLY INDEPENDENT...
C    KEYWORD  VARIABLE  FORMAT  DEFAULT   DESCRIPTION
C    'NORTH'  NORTH     FLOAT   0.        DIR OF NRTH DEG CLKWS FRM UP
C    'ADIP'   ADIP      FLOAT   255./90.  DN(DIP) = ADIP*(DIP+BDIP)
C    'BDIP'   BDIP      FLOAT   0.
C    'AAZ '   AAZ       FLOAT   256./360. DN(AZIM)=AAZ*(AZIMUTH+BAZ)
C    'BAZ '   BAZ       FLOAT   0.
C    'LSCA'LE LSCALE    FLOAT   .01       LINE SCALE, IN MILES/LINE
C    'SSCA'LE SSCALE    FLOAT   .01       SAMPLE SCALE, IN MILES/SAMPLE
C    'AALT'   AALT      FLOAT   1.0 FT/DN ALTITUDE=AALT*DN(ALT)
C***************************************************************************
      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44

      IMPLICIT NONE

      COMMON ALT,DIP,AZIM,XSSC,YLSC,TADIP,TAAZ,TBDIP,TBAZ,NSO,
     +        TWOPI,RNRTH

      INTEGER   MAXSAMP                   !If changed, be sure to change the
      PARAMETER (MAXSAMP=32000)           !  MAXSAMP parameter in CMPT, too!

      INTEGER*2  ALT(3*MAXSAMP+8)         ! altitude array
      INTEGER*2  DIP(MAXSAMP)             ! gradient magnitude array
      INTEGER*2  AZIM(MAXSAMP)            ! gradient direction array
      INTEGER*2  TDIP(MAXSAMP/2)          ! TEMPORARY ARRAYS
      INTEGER*2  TAZI(MAXSAMP/2)
      REAL*4  TXBU(MAXSAMP/2)
      REAL*4  TYBU(MAXSAMP/2)

      COMMON/DERIVATIVE/XBUF,YBUF,FORMAT
      REAL*4     XBUF(MAXSAMP)            ! x partial derivative
      REAL*4     YBUF(MAXSAMP)            ! y partial derivative
      INTEGER*2  FORMAT                   ! format type

      INTEGER*4  NLO1, NBO1, NLO_CENT, NBO_CENT, J, K, INC, NOW

      CHARACTER*72 LBL

      REAL*4  PI                     ! value of PI
      REAL*4  NORTH                  ! DIR OF NRTH, DEG CLKWS FRM UP
      REAL*4  ADIP                   ! DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  BDIP                   ! DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  AAZ                    ! DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  BAZ                    ! DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  LSCALE                 ! LINE SCALE, IN MILES/LINE
      REAL*4  SSCALE                 ! SAMPLE SCALE, IN MILES/SAMPLE
      REAL*4  AALT                   ! ALTITUDE=AALT*DN(ALT)+BALT
      REAL*4  VAL(8)                 ! FOR SUBROUTINE EQUIVALENCE
      REAL*4  XSSC,YLSC,TWOPI,RNRTH  ! FOR SUBROUTINE COMMONALITY
      REAL*4  TADIP,TAAZ,TBDIP,TBAZ  ! FOR VARIABLE INITIALIZATION

      EQUIVALENCE (VAL(1),NORTH),(VAL(2),ADIP),(VAL(3),BDIP)
      EQUIVALENCE (VAL(4),AAZ),(VAL(5),BAZ),(VAL(6),LSCALE)
      EQUIVALENCE (VAL(7),SSCALE),(VAL(8),AALT)

      CHARACTER*132 input(2)         ! input files
      CHARACTER*132 output(4)        ! output files
      CHARACTER*12 IFORMAT           ! input format byte or half ?
      CHARACTER*12 DFORMAT           ! x,y derivative output format

      INTEGER*4 SL                   ! starting line
      INTEGER*4 SB                   ! starting sample
      INTEGER*4 NLO                  ! number of lines output
      INTEGER*4 NBO                  ! number of samples output
      INTEGER*4 NLI                  ! number of lines input
      INTEGER*4 NBI                  ! number of samples input
      INTEGER*4 LINE, LIN, NB, NSO   ! temp variables
      INTEGER*4 NDSI, IDEF, NDSO     ! temp variables
      INTEGER*4 IPIXSIZ, ICOUNT      ! temp variables
      INTEGER*4 IPNT,JPNT,KPNT,N,I   ! temp variables
      INTEGER*4 NI,NJ,NK,N1,N2,N3,N4 ! temp variables

      INTEGER*4 inunit               ! unit of input data set
      INTEGER*4 outunit(4)           ! up to 4 units for output data sets
      INTEGER*4 status               ! status of xv returns

      LOGICAL*1 HALF                 ! default for halfword input
      LOGICAL VERBOSE,CENTERED,XVPTST

      DATA PI /3.1415927/            ! value of pi
      DATA HALF /.TRUE./             ! default for halfword input
      DATA input(1) /' '/
      DATA input(2) /' '/
      DATA VAL /8*0.0/               ! initialize array
      DATA IPIXSIZ /0/
      DATA IFORMAT /' '/
      DATA DFORMAT /' '/

C------------------------------------------------------------------------
C
C                PROCESS PARAMETERS, CHECK FOR ERROR CONDITIONS,
C                            AND OPEN DATA SETS
C
C------------------------------------------------------------------------

      LINE = 0
      LIN  = 0

      VERBOSE = XVPTST('VERBOSE')
      CALL xveaction ('SA',' ')
      CALL ifmessage('PIXGRAD version 05-SEP-94')

      call xvparm ('INP', input, NDSI, IDEF, 1)
      IF ( NDSI .NE. 1 ) THEN
         CALL xvmessage
     +           ('$$$ INCORRECT NUMBER OF INPUT DATA SETS $$$',' ')
         CALL abend
      END IF

      call xvunit ( inunit, 'INP', 1, status, ' ' ) ! get unit for input data
      call xvopen  ( inunit, status, 'U_NL', 512, 'U_NS', 512,
     -                   'U_FORMAT','HALF','I_FORMAT','HALF', ' ')

      call xvparm ( 'OUT', output, NDSO, IDEF, 4 )
      IF ( NDSO .lt. 2 ) THEN
         CALL xvmessage
     +           ('$$$ INCORRECT NUMBER OF OUTPUT DATA SETS $$$',' ')
         CALL abend
      END IF

      centered = XVPTST('CENTER') ! FOR CENTERED OUTPUT DATA SET

      call xvsize ( SL, SB, NLO, NBO, NLI, NBI )

      if ( .not. centered ) then
          IF ( SL + NLO .GT. 1 + NLI ) THEN
             CALL xvmessage('$$$ REQUESTED SIZE FIELD EXCEEDS',' ')
             CALL xvmessage('    INPUT PICTURE LENGTH. $$$',' ')
             CALL abend
          END IF
      else              ! reset output sample size
          nlo_cent = nlo / 3
          nbo_cent = nbo / 3
      end if

      CALL xvget(inunit, status, 'PIX_SIZE', IPIXSIZ,
     +             'FORMAT', IFORMAT,' ')! BYTES PER PIXEL AND FORMAT.
      HALF = IPIXSIZ .EQ. 2
      IF ( IPIXSIZ .NE. 1 .AND. IPIXSIZ .NE. 2 )
     .     CALL mabend('ERROR:INP. IMAGE IS NOT BYTE OR HALF FORMAT')

      call xvp ( 'NORTH',  NORTH,  icount )
      call xvp ( 'ADIP',   ADIP,   icount )
      call xvp ( 'BDIP',   BDIP,   icount )
      call xvp ( 'AAZ',    AAZ,    icount )
      call xvp ( 'BAZ',    BAZ,    icount )
      call xvp ( 'LSCALE', LSCALE, icount )
      call xvp ( 'SSCALE', SSCALE, icount )
      call xvp ( 'AALT',   AALT,     icount )
      call xvp ( 'FORMAT', DFORMAT,  icount )

      if ( dformat .eq. 'REAL' ) then  ! x,y derivative output format
          format = 1
      else
          format = 0
      end if

      call xvclose(inunit, status,' ')       ! close input
      if ( IFORMAT .eq. 'BYTE' ) then          ! reopen properly
         call xvopen(inunit, status, 'U_NL', NLI, 'U_NS', NBI,
     -                   'U_FORMAT','HALF','I_FORMAT','BYTE',' ')
      else
         call xvopen(inunit, status, 'U_NL', NLI, 'U_NS', NBI,
     -                   'U_FORMAT','HALF','I_FORMAT','HALF',' ')
      end if

c
c     Open output files
c
      call xvunit(outunit(1), 'OUT', 1, status,' ') ! first output data set
      call xvunit(outunit(2), 'OUT', 2, status,' ') ! second output data set
      if ( ndso .gt. 2 ) then
          call xvunit(outunit(3), 'OUT', 3, status,' ') ! x derivative
          call xvunit(outunit(4), 'OUT', 4, status,' ') ! y derivative
      end if

      if ( centered ) then  ! set output lines and samples
          nlo1 = NLO_CENT
          nbo1 = NBO_CENT
      else
          nlo1 = nlo
          nbo1 = nbo
      end if

      call xvopen(outunit(1), status,   ! OPEN THE FIRST TWO DATA SETS
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','HALF','O_FORMAT','BYTE','OP','WRITE',' ')

      write (LBL,50) AAZ, BAZ
      if (VERBOSE) CALL xvmessage(LBL,' ')

      call xvopen(outunit(2), status,
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','HALF','O_FORMAT','BYTE','OP','WRITE',' ')

C
C     check for derivative outputs
C

      if ( ndso .gt. 2 ) then
          if (  FORMAT .eq. 0 ) then           ! byte data output
              call xvopen(outunit(3), status,
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','REAL','O_FORMAT','REAL','OP','WRITE',' ')

              write (LBL,50) AAZ, BAZ
              if (VERBOSE) CALL xvmessage(LBL,' ')

              call xvopen(outunit(4), status,
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','REAL','O_FORMAT','REAL','OP','WRITE',' ')
          else
              call xvopen(outunit(3), status,
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','REAL','O_FORMAT','REAL','OP','WRITE',' ')

              write (LBL,50) AAZ, BAZ
              if (VERBOSE) CALL xvmessage(LBL,' ')

              call xvopen(outunit(4), status,
     -           'U_NL', NLO1, 'U_NS', NBO1,
     -           'U_FORMAT','REAL','O_FORMAT','REAL','OP','WRITE',' ')
          end if
      end if

      CALL INITL(VAL,VERBOSE)  ! initialize and print initial/default values

C------------------------------------------------------------------------
C
C                             PROCESS DATA
C
C------------------------------------------------------------------------

      BDIP=BDIP*ADIP
      BAZ=BAZ*AAZ

      NB=NBO
      NSO=NB

      IF ( ( SB-1 + NB ) .GT. NBI ) THEN
         CALL xvmessage('$$$ REQUESTED SIZE FIELD EXCEEDS',' ')
         CALL xvmessage('      INPUT PICTURE WIDTH $$$',' ')
         CALL abend
      END IF

      NBI=NSO

      write (LBL,50) ADIP, BDIP
      if (VERBOSE) CALL xvmessage(LBL,' ')

      IF ( SL .eq. 1 ) THEN                      ! read input
         call xvread(inunit,ALT(MAXSAMP+4),status,'LINE',SL,'SAMP',SB,
     -                  'NSAMPS',NB,' ')
         if ( status .ne. 1 ) then
            call xvmessage('Input error read. Program terminated.',' ')
            call abend
         end if
      else
         N = SL - 1
         call xvread(inunit,ALT(2),status,'LINE',N,'SAMP',SB,
     -                  'NSAMPS',NB,' ')
         if ( status .ne. 1 ) then
            call xvmessage('Input error read. Program terminated.',' ')
            call abend
         end if
      END IF

      ALT((MAXSAMP+3)) = ALT((MAXSAMP+4))
      ALT((MAXSAMP+4)+NSO) = ALT((MAXSAMP+3)+NSO)

      IF( SL .EQ. 1 ) THEN
         N = NSO + 2
         DO I=1,N
            ALT(I) = ALT(I+(MAXSAMP+2))
         END DO
      END IF

      ALT(1) = ALT(2)
      ALT(NSO+2) = ALT(NSO+1)

      IPNT=1
      JPNT=2
      NI=0
      NJ=(MAXSAMP+2)

C***************************************************************************
C        IPNT  POINTS TO CURRENT LINE (LINE TO WRITE)
C        JPNT  POINTS TO CURRENT+1 LINE
C        KPNT  POINTS TO CURRENT-1 LINE
C        LINE REFERS TO LINE BEING READ
C***************************************************************************

      now  = 2

      DO LINE = 2, NLO                              ! loop for lines out
         LIN=LINE-1
         IPNT=IPNT+1
         KPNT=IPNT-1
         JPNT=JPNT+1

         IF(IPNT.EQ.4) IPNT=1
         IF(JPNT.EQ.4) JPNT=1

         NK=NI
         NI=NJ
         NJ=(MAXSAMP+2)*(JPNT-1)
         N1=NI+2
         N2=NJ+1
         N3=NK+1
         N4=NJ+2

         call xvread(inunit,ALT(N4),status,'LINE',LINE,
     -              'SAMP',SB,'NSAMPS',NB,' ')
         if ( status .ne. 1 ) then
            call xvmessage('Input error read. Program terminated.',' ')
            call abend
         end if

         ALT(N4-1)=ALT(N4)
         ALT(N4+NSO)=ALT(N4+NSO-1)

         CALL CMPT(NI,N1,N2,N3)

         write(LBL,100) LINE
         if (VERBOSE) CALL xvmessage (LBL,' ')

         IF ( CENTERED ) THEN
             IF ( NOW .EQ. LINE ) THEN
                 NOW = NOW + 3          ! UPDATE NEXT REQUIRED LINE #
                 K = 1                  ! START OF RESAMPLED ARRAYS
                 INC = 3                ! FOR CENTERED STUFF
                 DO J = 2,NBO,INC  ! RESAMPLE ARRAYS
                     TDIP(K) = DIP(J)
                     TAZI(K) = AZIM(J)
                     TXBU(K) = XBUF(J)
                     TYBU(K) = YBUF(J)
                     K = K + 1
                 END DO
                 call xvwrit(outunit(1),TDIP,status,
     -                       'NSAMPS',NBO1,' ')
                 if ( status .ne. 1 ) then
                      call xvmessage('Input error read.',' ')
                      call abend
                 end if
                 call xvwrit(outunit(2),TAZI,status,
     -                       'NSAMPS',NBO1,' ')
                 if ( status .ne. 1 ) then
                      call xvmessage('Input error read.',' ')
                      call abend
                 end if
                 if ( NDSO .gt. 2 ) then    ! derivatives
                     call xvwrit(outunit(3),TXBU,status,
     -                       'NSAMPS',NBO1,' ')
                     if ( status .ne. 1 ) then
                          call abend
                     end if
                     call xvwrit(outunit(4),TYBU,status,
     -                       'NSAMPS',NBO1,' ')
                     if ( status .ne. 1 ) then
                         call xvmessage('Input error read.',' ')
                         call abend
                     end if
                 END IF
             end if
         ELSE
             call xvwrit(outunit(1),DIP,status,'NSAMPS',NSO,' ')
             if ( status .ne. 1 ) then
                 call xvmessage('Input error read.',' ')
                 call abend
             end if
             call xvwrit(outunit(2),AZIM,status,'NSAMPS',NSO,' ')
             if ( status .ne. 1 ) then
                 call xvmessage('Input error read.',' ')
                 call abend
             end if
             if ( NDSO .gt. 2 ) then    ! derivatives
                 call xvwrit(outunit(3),XBUF,status,'NSAMPS',NSO,' ')
                 if ( status .ne. 1 ) then
                     call xvmessage('Input error read.',' ')
                     call abend
                 end if
                 call xvwrit(outunit(4),YBUF,status,'NSAMPS',NSO,' ')
                 if ( status .ne. 1 ) then
                     call xvmessage('Input error read.',' ')
                     call abend
                 end if
             end if
         end if
      END DO

      LIN=LIN+1
      IPNT=IPNT+1
      JPNT=JPNT+1
      KPNT=IPNT-1
      IF(IPNT.EQ.4) IPNT=1
      IF(JPNT.EQ.4) JPNT=1
      NK=NI
      NI=NJ
      NJ=(MAXSAMP+2)*(JPNT-1)
      N1=NI+2
      N2=NJ+1
      N3=NK+1
      N4=NJ+2

      N=NSO+2
      DO I=1,N
         ALT(N2+I) = ALT(NI+1+I)
      END DO

      CALL CMPT(NI,N1,N2,N3)

      call xvwrit(outunit(1),DIP,status,'NSAMPS',NSO,' ')
      if ( status .ne. 1 ) then
         call xvmessage('Input error read. Program terminated.',' ')
         call abend
      end if
      call xvwrit(outunit(2),AZIM,status,'NSAMPS',NSO,' ')
      if ( status .ne. 1 ) then
         call xvmessage('Input error read. Program terminated.',' ')
         call abend
      end if

C**********************************************************************
C
C                       CLOSE DATA SETS
C
C**********************************************************************

      call xvclose(inunit, status,' ')          ! close input data set
      if ( status .ne. 1 ) call xvmessage('Input close error',' ')

      call xvclose(outunit(1), status,' ')    ! close output data sets
      if ( status .ne. 1 ) call xvmessage('Output close error',' ')
      call xvclose(outunit(2), status,' ')
      if ( status .ne. 1 ) call xvmessage('Output close error',' ')

      if ( ndso .gt. 2 ) then
          call xvclose(outunit(3), status,' ')
          if ( status .ne. 1 ) call xvmessage('Output close error',' ')
          call xvclose(outunit(4), status,' ')
          if ( status .ne. 1 ) call xvmessage('Output close error',' ')
      end if

50    format('GRADIENT DIRECTION PICTURE... DN=',F7.3,
     +       '*AZIMUTH(DEG).',F7.3)
100   format(' WRITING TO DISK',I12)

      RETURN
      END

C**************************************************************************
C  This subroutine computes the X, Y, Z for each sample and then uses
C  the results or defaults and computes the DIP and AZIMUTH arrays.
C***************************************************************************
      SUBROUTINE CMPT(NI,N1,N2,N3)

      IMPLICIT NONE

      COMMON ALT,DIP,AZIM,XSSC,YLSC,TADIP,TAAZ,TBDIP,TBAZ,NSO,
     +        TWOPI,RNRTH

      INTEGER   MAXSAMP              !If changed, be sure to change the
      PARAMETER (MAXSAMP=32000)      !  MAXSAMP parameter in CMPT, too!

      INTEGER*2 ALT(3*MAXSAMP+8),DIP(MAXSAMP),AZIM(MAXSAMP)

      REAL*4  XSSC                   ! init AALT/(5280.*LSCALE*N) N=(2,6,8)
      REAL*4  YLSC                   ! init AALT/(5280.*SSCALE*N) N=(2,6,8)
      REAL*4  TADIP                  ! init DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  TAAZ                   ! init DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  TBDIP                  ! init DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  TBAZ                   ! init DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  TWOPI                  ! 2.*PI
      REAL*4  RNRTH                  ! TWOPI-PIF*NORTH
      REAL*4  X,Y,Z                  ! temporary variables
      REAL*4  PI                     ! value of PI
      REAL*4  A,B,C,D,E,F,G,H,J

      LOGICAL XVPTST

      INTEGER*4 NI,N1,N2,N3,NSO,ISMPL   ! temp variables

      DATA PI /3.1415927/

      COMMON/DERIVATIVE/XBUF,YBUF,FORMAT
      REAL*4     XBUF(MAXSAMP)            ! x partial derivative
      REAL*4     YBUF(MAXSAMP)            ! y partial derivative
      INTEGER*2  FORMAT                   ! format type

C   Picture:
C
C                 N3+ISMPL
C       NI+ISMPL            N1+ISMPL
C                 N2+ISMPL
C
C

      IF (XVPTST('ARCINFO')) THEN
        DO ISMPL=1,NSO
	   A = ALT(N3+ISMPL-1)
	   B = ALT(N3+ISMPL)
	   C = ALT(N3+ISMPL+1)
	   D = ALT(NI+ISMPL)
	   E = ALT(NI+ISMPL+1)
	   F = ALT(N1+ISMPL)
	   G = ALT(N2+ISMPL-1)
	   H = ALT(N2+ISMPL)
	   J = ALT(N2+ISMPL+1)
           X=((C+2*F+J) - (A+2*D+G))*XSSC  !Fixed 01/08/97 --ndr
           Y=((g+2*h+j) - (a+2*b+c))*YLSC  ! swapped bam - 12/98
           Z=X*X+Y*Y

                                     ! GET THE PARTIAL DERIVATIVES
           XBUF(ISMPL) = X
           YBUF(ISMPL) = Y
c           IF ( FORMAT .EQ. 0 ) THEN      ! SHRINK INTO A BYTE
c               XBUF(ISMPL) = XBUF(ISMPL)
c               YBUF(ISMPL) = YBUF(ISMPL)
c           END IF

           IF ( Z .LE. .0001 ) THEN
             DIP(ISMPL) = TBDIP
             AZIM(ISMPL)= TBAZ
           ELSE
             DIP(ISMPL)=TADIP*ATAN(SQRT(Z))+TBDIP
             AZIM(ISMPL)= TAAZ*AMOD(ATAN2(-X,Y)+RNRTH,TWOPI)+TBAZ
           END IF

        END DO

      ELSE IF (XVPTST('ERDAS')) THEN

        DO ISMPL=1,NSO
	   A = ALT(N3+ISMPL-1)
	   B = ALT(N3+ISMPL)
	   C = ALT(N3+ISMPL+1)
	   D = ALT(NI+ISMPL)
	   E = ALT(NI+ISMPL+1)
	   F = ALT(N1+ISMPL)
	   G = ALT(N2+ISMPL-1)
	   H = ALT(N2+ISMPL)
	   J = ALT(N2+ISMPL+1)
           X=((C+F+J) - (A+D+G))*XSSC  !Fixed 01/08/97 --ndr
           Y=((g+h+j) - (a+b+c))*YLSC  ! swapped bam - 12/98
           Z=X*X+Y*Y

           XBUF(ISMPL) = X
           YBUF(ISMPL) = Y
c           IF ( FORMAT .EQ. 0 ) THEN      ! SHRINK INTO A BYTE
c               XBUF(ISMPL) = XBUF(ISMPL)
c               YBUF(ISMPL) = YBUF(ISMPL)
c           END IF

           IF ( Z .LE. .0001 ) THEN
             DIP(ISMPL)=TBDIP
             AZIM(ISMPL)=TBAZ
           ELSE
             DIP(ISMPL)=TADIP*ATAN(SQRT(Z))+TBDIP
             AZIM(ISMPL)= TAAZ*AMOD(ATAN2(-X,Y)+RNRTH,TWOPI)+TBAZ
           END IF
        END DO
      ELSE
        DO ISMPL=1,NSO
           X=(ALT(N1+ISMPL)-ALT(NI+ISMPL))*XSSC
           Y=(ALT(N2+ISMPL)-ALT(N3+ISMPL))*YLSC
           Z=X*X+Y*Y

           XBUF(ISMPL) = X
           YBUF(ISMPL) = Y
c           IF ( FORMAT .EQ. 0 ) THEN      ! SHRINK INTO A BYTE
c               XBUF(ISMPL) = XBUF(ISMPL)
c               YBUF(ISMPL) = YBUF(ISMPL)
c           END IF

           IF ( Z .LE. .0001 ) THEN
             DIP(ISMPL)=TBDIP
             AZIM(ISMPL)=TBAZ
           ELSE
             DIP(ISMPL)=TADIP*ATAN(SQRT(Z))+TBDIP
             AZIM(ISMPL)= TAAZ*AMOD(ATAN2(-X,Y)+RNRTH,TWOPI)+TBAZ
           END IF
        END DO
      END IF
      RETURN
      END

C------------------------------------------------------------------------
C  INITL is an entry point to subroutine CMPT.  THis entry point is used
C  only once to intiialize or set the default values for user parameters.
C  The user parameters or defaults are printed out and saved via common
C  for subsequent calls to the CMPT subroutine.

C  BAM - MODIFIED TO A SUBROUTINE SO THAT IT CAN BE LOOKED AT IN THE DEBUGGER

C------------------------------------------------------------------------

      SUBROUTINE INITL(VAL,VERBOSE)

      implicit none

      COMMON ALT,DIP,AZIM,XSSC,YLSC,TADIP,TAAZ,TBDIP,TBAZ,NSO,
     +        TWOPI,RNRTH

      INTEGER   MAXSAMP              !If changed, be sure to change the
      PARAMETER (MAXSAMP=32000)      !  MAXSAMP parameter in CMPT, too!

      INTEGER   NSO

      INTEGER*2 ALT(3*MAXSAMP+8),DIP(MAXSAMP),AZIM(MAXSAMP)

      REAL*4  XSSC                   ! init AALT/(5280.*LSCALE*N) N=(2,6,8)
      REAL*4  YLSC                   ! init AALT/(5280.*SSCALE*N) N=(2,6,8)
      REAL*4  TADIP                  ! init DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  TAAZ                   ! init DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  TBDIP                  ! init DN(DIP) = ADIP*(DIP+BDIP)
      REAL*4  TBAZ                   ! init DN(AZIM)=AAZ*(AZIMUTH+BAZ)
      REAL*4  TWOPI                  ! 2.*PI
      REAL*4  RNRTH                  ! TWOPI-PIF*NORTH
      REAL*4  VAL(8)                 ! FOR SUBROUTINE EQUIVALENCE
      REAL*4  PI                     ! value of PI
      REAL*4  PIF                    ! value of PI/180
      REAL*4  VAL9                   ! To print zero

      LOGICAL VERBOSE,XVPTST
      DATA PI /3.1415927/            ! value of pi
      CHARACTER*80 MSG1

      PIF = PI / 180.
      VAL9 = 0.0
      WRITE (MSG1,200) VAL(8), VAL9
      if (VERBOSE) call xvmessage(MSG1,' ')
      WRITE (MSG1,500) VAL(6)
      if (VERBOSE) call xvmessage(MSG1,' ')
      WRITE (MSG1,600) VAL(7)
      if (VERBOSE) call xvmessage(MSG1,' ')
      WRITE (MSG1,300) VAL(2), VAL(3)
      if (VERBOSE) call xvmessage(MSG1,' ')
      WRITE (MSG1,400) VAL(4), VAL(5)
      if (VERBOSE) call xvmessage(MSG1,' ')

      XSSC  = VAL(8)/(5280.*VAL(6))
      YLSC  = VAL(8)/(5280.*VAL(7))

      if (XVPTST('ARCINFO')) then
        XSSC  = XSSC/8.0
        YLSC  = YLSC/8.0
      else if (XVPTST('ERDAS')) then
        XSSC  = XSSC/6.0
        YLSC  = YLSC/6.0
      else  ! standard
        XSSC  = XSSC/2.0
        YLSC  = YLSC/2.0
      end if

      TADIP  = VAL(2)/PIF
      TAAZ   = VAL(4)/PIF
      TWOPI = 2.*PI
      RNRTH = TWOPI-PIF*VAL(1)
      TBDIP  = VAL(3)+.5
      TBAZ   = VAL(5)+.5

200   format('             ALTITUDE PICTURE...      ALT=', F8.3,
     +       ' * DN   +',F9.3,' FT')
300   format('   GRADIENT MAGNITUDE PICTURE...       DN=', F8.3,
     +       ' * DIP  +',F9.3)
400   format('   GRADIENT DIRECTION PICTURE...       DN=', F8.3,
     +       '*AZIMUTH+',F9.3)
500   format('         SAMPLE SCALE IS ',F8.4,' MILES/PXL')
600   format('           LINE SCALE IS ',F8.4,' MILES/PXL')
      RETURN
      END


        SUBROUTINE AIRYB(X,AI,BI,AD,BD)
C
C       =======================================================
C       Purpose: Compute Airy functions and their derivatives
C       Input:   x  --- Argument of Airy function
C       Output:  AI --- Ai(x)
C                BI --- Bi(x)
C                AD --- Ai'(x)
C                BD --- Bi'(x)
C       =======================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION CK(41),DK(41)
        EPS=1.0D-15
        PI=3.141592653589793D0
        C1=0.355028053887817D0
        C2=0.258819403792807D0
        SR3=1.732050807568877D0
        XA=DABS(X)
        XQ=DSQRT(XA)
        IF (X.GT.0.0D0) XM=5.0
        IF (X.LE.0.0D0) XM=8.0
        IF (X.EQ.0.0D0) THEN
           AI=C1
           BI=SR3*C1
           AD=-C2
           BD=SR3*C2
           RETURN
        ENDIF
        IF (XA.LE.XM) THEN
           FX=1.0D0
           R=1.0D0
           DO 10 K=1,40
              R=R*X/(3.0D0*K)*X/(3.0D0*K-1.0D0)*X
              FX=FX+R
              IF (DABS(R).LT.DABS(FX)*EPS) GO TO 15
10         CONTINUE
15         GX=X
           R=X
           DO 20 K=1,40
              R=R*X/(3.0D0*K)*X/(3.0D0*K+1.0D0)*X
              GX=GX+R
              IF (DABS(R).LT.DABS(GX)*EPS) GO TO 25
20         CONTINUE
25         AI=C1*FX-C2*GX
           BI=SR3*(C1*FX+C2*GX)
           DF=0.5D0*X*X
           R=DF
           DO 30 K=1,40
              R=R*X/(3.0D0*K)*X/(3.0D0*K+2.0D0)*X
              DF=DF+R
              IF (DABS(R).LT.DABS(DF)*EPS) GO TO 35
30         CONTINUE
35         DG=1.0D0
           R=1.0D0
           DO 40 K=1,40
              R=R*X/(3.0D0*K)*X/(3.0D0*K-2.0D0)*X
              DG=DG+R
              IF (DABS(R).LT.DABS(DG)*EPS) GO TO 45
40         CONTINUE
45         AD=C1*DF-C2*DG
           BD=SR3*(C1*DF+C2*DG)
        ELSE
           XE=XA*XQ/1.5D0
           XR1=1.0D0/XE
           XAR=1.0D0/XQ
           XF=DSQRT(XAR)
           RP=0.5641895835477563D0
           R=1.0D0
           DO 50 K=1,40
              R=R*(6.0D0*K-1.0D0)/216.0D0*(6.0D0*K-3.0D0)
     &          /K*(6.0D0*K-5.0D0)/(2.0D0*K-1.0D0)
              CK(K)=R
50            DK(K)=-(6.0D0*K+1.0D0)/(6.0D0*K-1.0D0)*CK(K)
           KM=INT(24.5-XA)
           IF (XA.LT.6.0) KM=14
           IF (XA.GT.15.0) KM=10
           IF (X.GT.0.0D0) THEN
              SAI=1.0D0
              SAD=1.0D0
              R=1.0D0
              DO 55 K=1,KM
                 R=-R*XR1
                 SAI=SAI+CK(K)*R
55               SAD=SAD+DK(K)*R
              SBI=1.0D0
              SBD=1.0D0
              R=1.0D0
              DO 60 K=1,KM
                 R=R*XR1
                 SBI=SBI+CK(K)*R
60               SBD=SBD+DK(K)*R
              XP1=DEXP(-XE)
              AI=0.5D0*RP*XF*XP1*SAI
              BI=RP*XF/XP1*SBI
              AD=-.5D0*RP/XF*XP1*SAD
              BD=RP/XF/XP1*SBD
           ELSE
              XCS=DCOS(XE+PI/4.0D0)
              XSS=DSIN(XE+PI/4.0D0)
              SSA=1.0D0
              SDA=1.0D0
              R=1.0D0
              XR2=1.0D0/(XE*XE)
              DO 65 K=1,KM
                 R=-R*XR2
                 SSA=SSA+CK(2*K)*R
65               SDA=SDA+DK(2*K)*R
              SSB=CK(1)*XR1
              SDB=DK(1)*XR1
              R=XR1
              DO 70 K=1,KM
                 R=-R*XR2
                 SSB=SSB+CK(2*K+1)*R
70               SDB=SDB+DK(2*K+1)*R
              AI=RP*XF*(XSS*SSA-XCS*SSB)
              BI=RP*XF*(XCS*SSA+XSS*SSB)
              AD=-RP/XF*(XCS*SDA+XSS*SDB)
              BD=RP/XF*(XSS*SDA-XCS*SDB)
           ENDIF
        ENDIF
        RETURN
        END


      subroutine qinf(m,ealpha,efflen,aveks,effdrr,f,runoff)
c
c     + + + PURPOSE + + +
c
c     Called from IRS to compute the reduction of runoff volume caused
c     by infiltration during the recession for partial equilibrium
c     hydrographs.  The reduction is computed as
c
c     qvstar = 1/(m+1) * (fstar+1)/fstar * tstar**(-m)
c                for     tstar >= ((fstar+1)/fstar)**(1/m)
c     and
c
c     qvstar = 1 - m/(m+1) * (fstar/(fstar+1))**(1/m) * tstar
c                for     tstar <  ((fstar+1)/fstar)**(1/m)
c
c     where
c        qvstar = runoff/recum(ns)                         (nd)
c        fstar  = f(nstemp-1)/vave                         (nd)
c        tstar  = te/effdrr                                (nd)
c        vave   = average rainfall excess rate             (m/s)
c        effdrr = duration of rainfall excess              (s)
c        f      = infiltration rate at end of event        (m/s)
c        runoff = adjusted runoff                          (m)
c        te     = time to kinematic equilibrium            (s)
c        m      = kinematic depth-discharge exponent       (nd)
c
c     Author: J.J. Stone
c     Reference in User Guide: Chapter 4.
c
c     Version: Created March 1994
c
c     + + + KEYWORDS + + +
c
c     kinematic wave model, adjusted runoff volume,
c     time to kinematic equilibrium, recession infiltration,
c     partial equilibrium
c
c     + + + PARAMETERS + + +
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real        m,ealpha,efflen,aveks,effdrr,f,runoff
c
c     + + + ARGUMENT DEFINTIONS + + +
c
c     m       - depth-discharge exponent
c     ealpha  - effective depth-discharge coefficient
c     efflen  - effective length
c     aveks   - average effective saturated conductivity
c     effdrr  - effective rainfall excess duration
c     f       - final infiltration rate
c     runoff  - adjusted runoff volume
c
c     + + + COMMON BLOCKS + + +
c
      include 'ctemp.inc'
c       read solwpv
c
c     + + + LOCAL VARIABLES + + +
c
      real             vave,te,fstar,ftest,qvstar,tstar
c
c     + + + LOCAL DEFINITIONS + + +
c
c     vave    - average rainfall excess rate
c     te      - time to kinematic equilibrium
c     tstar   - dimensionless time
c     fstar   - dimensionless infiltration rate
c     ftest   - ((fstar+1)/fstar)**(1/m)
c     qvstar  - dimensionless runoff volume
c
      vave  = runoff/effdrr
      te    = (efflen/(ealpha*vave**(m-1)))**(1/m)
      tstar = te/effdrr
      fstar = aveks/vave
c
      if (f .gt. 0.) then
        fstar = f/vave
c
        ftest = ((fstar+1)/fstar)**(1/m)
c
c       Add new IF in order to activate computation of recession
c       infiltration for partial equilibrium events when version
c       control value in the soil input file is equal to or
c       greater than 2001.0 (reflag=1)     dcf  2/6/2001
c       if ((solwpv.gt.2000.and.solwpv.ne.7777)
c    1       .or. tstar .ge. 1 ) then
c
c       Make test to use recession infiltration as originally
c       provided from Jeff Stone (no version control). dcf 3-17-04
        if (tstar .ge. 1.0) then
c
c         partial equilibrium - reduce runoff volume
c
          if (tstar .ge. ftest) then
            qvstar = 1/(m+1)*(fstar+1)/fstar*tstar**(-m)
          else
            qvstar = 1-m/(m+1)*(fstar/(fstar+1))**(1/m) * tstar
          end if
          runoff = runoff*qvstar
        end if
      end if
c
      return
      end


      subroutine runCF_iiii(i1,i2,i3,i4,m0sq,Gr,Bzero4,N0)
C---  Expression for rearrangement of extension of Eq. 5.69
C---  Calculates Ciiii, requires C00iiii
C---  Small terms of order Gr(i,j)*Cijklmn
C---  Denominator m0sq
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,i2,i3,i4,m,n,np
      parameter(np=2)
      double precision m0sq,Gr(np,np)
      double complex Bzero4(z4max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(ciiiiii(z6(n,m,i1,i2,i3,i4))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(czziiii(z4(i1,i2,i3,i4))+N0,ep-1)

      Cv(ciiii(z4(i1,i2,i3,i4))+N0,ep)=
     . (24d0*Cv(czziiii(z4(i1,i2,i3,i4))+N0,ep)
     . -pole
     . -2d0*Bzero4(z4(i1,i2,i3,i4),ep)
     . +bit)/(2d0*m0sq)

      enddo

      return
      end


 SUBROUTINE nearsa(xc,nsegm,nearn,xs,tc,tn,maxdi,cutoff)

 !.... look for the nearest master segment using a GLOBAL searching algorithm
 !.... output:  nearn = number of the nearest master segment
 USE ctrl_db, ONLY : ndime
 IMPLICIT NONE
 !     arguments
 INTEGER (kind=4), INTENT (IN) :: nsegm   !number of segments in surface
 INTEGER (kind=4), INTENT (OUT) :: nearn  !segment candidate
 REAL (kind=8), INTENT (IN) :: xc(:,:), & ! xc = current coordinates of the segment center
                               xs(:),   & ! xs = current coordinates of the slave node
                               tc(:,:), & ! tc = current normals at segments
                               tn(:),   & ! tn = current normal at node
                               maxdi,   & ! maximum distance
                               cutoff     ! maximum penetration
 !     local variables
 INTEGER (kind=4) iseg
 REAL    (kind=8) vdist(ndime),d,dmin,cang

 !.... initialize values
 dmin  = 1d10        !a large value
 nearn = 0           !no candidate
 !.... loop over all master segments
 DO iseg = 1, nsegm
   cang = DOT_PRODUCT(tc(:,iseg),tn)     !angle between normals
   IF( cang > 0d0 )CYCLE                 !if |angle| < pi/2 discard segment
   vdist = xs(:) - xc(:,iseg)            !distance vector  xs - xc
   cang = DOT_PRODUCT(tc(:,iseg),vdist)  !penetration
   IF( cang < cutoff .OR. cang > maxdi )CYCLE !penetration is too large or point too distant
   d = DOT_PRODUCT(vdist,vdist)    ! distance (squared)
   IF(d < dmin) THEN               ! check for minimum distance
     dmin = d                      ! updates minimun distance
     nearn = iseg                  ! updates nearest segment
   END IF
 END DO
 RETURN
 END SUBROUTINE nearsa


!!# MODULE <<FUN_NormEll2Sqr>>
MODULE FUN_NormEll2Sqr

!!## PURPOSE
!! Defines the $\ell^2$ norm of <A> squared, with optional weight <W>.

!!## DETAILS
!! The $\ell^2$-squared norm is just the $\ell^2$ norm without
!! the square root
!!
!! $$ [\ell^2(A)]^2 = \sum_i [ A_i ]^2 W_i  $$
!!
!! Where for example $A_i$ could be average values
!! $A_i = \frac{1}{\Delta x_i} \int_{a_i}^{b_i} A(x) dx$
!! and the weights $W_i = \Delta x_i$ returned from a finite
!! volume solution of a PDE.

!!## USAGE
!
!       s = NormEll2Sqr( A [,W] )
!

!!## REFERENCES
!
![1] Weisstein, Eric W. "L2-Norm." From MathWorld--A Wolfram Web Resource.
!    http://mathworld.wolfram.com/L2-Norm.html

!!## OWNER
![1] Wieselquist, William W. (william.wieselquist AT gmail.com)
!    July 8, 2006 - present

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## NormEll2Sqr PROCEDURE OVERLOADING
INTERFACE NormEll2Sqr
 MODULE PROCEDURE NormEll2Sqr_A1_Rsp
 MODULE PROCEDURE NormEll2Sqr_A2_Rsp
 MODULE PROCEDURE NormEll2Sqr_A3_Rsp
 MODULE PROCEDURE NormEll2Sqr_A4_Rsp
 MODULE PROCEDURE NormEll2Sqr_A5_Rsp
 MODULE PROCEDURE NormEll2Sqr_A6_Rsp
 MODULE PROCEDURE NormEll2Sqr_A7_Rsp

 MODULE PROCEDURE NormEll2Sqr_A1_Rdp
 MODULE PROCEDURE NormEll2Sqr_A2_Rdp
 MODULE PROCEDURE NormEll2Sqr_A3_Rdp
 MODULE PROCEDURE NormEll2Sqr_A4_Rdp
 MODULE PROCEDURE NormEll2Sqr_A5_Rdp
 MODULE PROCEDURE NormEll2Sqr_A6_Rdp
 MODULE PROCEDURE NormEll2Sqr_A7_Rdp
END INTERFACE
INTERFACE NormEll2Sqr
 MODULE PROCEDURE NormEll2Sqr_A1W1_Rsp
 MODULE PROCEDURE NormEll2Sqr_A2W2_Rsp
 MODULE PROCEDURE NormEll2Sqr_A3W3_Rsp
 MODULE PROCEDURE NormEll2Sqr_A4W4_Rsp
 MODULE PROCEDURE NormEll2Sqr_A5W5_Rsp
 MODULE PROCEDURE NormEll2Sqr_A6W6_Rsp
 MODULE PROCEDURE NormEll2Sqr_A7W7_Rsp

 MODULE PROCEDURE NormEll2Sqr_A1W1_Rdp
 MODULE PROCEDURE NormEll2Sqr_A2W2_Rdp
 MODULE PROCEDURE NormEll2Sqr_A3W3_Rdp
 MODULE PROCEDURE NormEll2Sqr_A4W4_Rdp
 MODULE PROCEDURE NormEll2Sqr_A5W5_Rdp
 MODULE PROCEDURE NormEll2Sqr_A6W6_Rdp
 MODULE PROCEDURE NormEll2Sqr_A7W7_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: NormEll2Sqr

!## MODULE PROCEDURES
CONTAINS

!!### L-2 Norm for single precision
PURE FUNCTION NormEll2Sqr_A1_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A2_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A3_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A4_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A5_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A6_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A7_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormEll2Sqr_A1_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A2_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A3_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A4_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A5_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A6_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A7_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 )
!!--end--
END FUNCTION

!!### L-2 Norm for single precision
PURE FUNCTION NormEll2Sqr_A1W1_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A2W2_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A3W3_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A4W4_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A5W5_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A6W6_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A7W7_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormEll2Sqr_A1W1_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A2W2_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A3W3_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A4W4_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A5W5_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A6W6_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

PURE FUNCTION NormEll2Sqr_A7W7_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ( A )**2 * W )
!!--end--
END FUNCTION

END MODULE


MODULE futils
IMPLICIT NONE
  ! PRIVATE

  double precision :: p  ! Period
  double precision :: p2 ! Period / 2

  public :: unmod
  public :: set_period
  public :: threshold_data
  public :: poincare_times_no_false_returns
  public :: poincare_times_interpolate

CONTAINS

  SUBROUTINE set_period( new_period )
  double precision, INTENT(in) :: new_period
    p = new_period
    p2 = 0.5D0 * p
  END SUBROUTINE set_period

  SUBROUTINE unmod (x, x_mod, num_samples)
  integer, INTENT(in) :: num_samples
  double precision, dimension(num_samples), INTENT(in) :: x_mod
  double precision, dimension(num_samples), INTENT(out) :: x
    integer :: i
    integer :: n
    double precision :: ph_diff
    n = 0
    x = x_mod
    DO i = 2, num_samples
      x(i) = x(i) + p * n
      ph_diff = x(i) - x(i-1)
      IF (ph_diff > p2) THEN
          n = n-1
          x(i) = x(i) - p
      ELSE IF (ph_diff < -p2) THEN
          n = n+1
          x(i) = x(i) + p
      END IF
    END DO
  END SUBROUTINE

  SUBROUTINE threshold_data (x, num_samples, threshold, n_min, segments, num_segments)
  double precision, dimension(num_samples), intent(in) :: x
  integer, intent(in) :: num_samples
  double precision, intent(in) :: threshold
  integer, intent(in) :: n_min
  integer, dimension(num_samples, 2), intent(out) :: segments
  integer, intent(out) :: num_segments
    integer :: n, n0
    num_segments = 0
    n0 = 1
    DO n = 1, num_samples
      IF (x(n) < threshold) THEN
        IF (n-n0 > n_min) THEN
          num_segments = num_segments + 1
          segments(num_segments, 1) = n0
          segments(num_segments, 2) = n-1
        END IF
        n0 = n
      END IF
    END DO
    IF (n-n0 > n_min) THEN
      num_segments = num_segments + 1
      segments(num_segments, 1) = n0
      segments(num_segments, 2) = n-1
    END IF
  END SUBROUTINE

  SUBROUTINE poincare_times_no_false_returns (cross_idx, ti, num_crossings, x_mod, x, num_samples)

  ! idx stores the indicies of the crossings
  ! ti stores the time indicies of return
  ! num_crossings stores the number of crossings
  ! x_mod is modded phase
  ! x is unmodded phase
  ! num_samples is length of x
  ! function stores positive times when x crosses 0

  integer, dimension(num_samples), intent(in) :: x_mod, x
  integer, intent(in) :: num_samples
  integer, INTENT(out) :: num_crossings
  integer, dimension(num_samples), intent(out) :: cross_idx
  integer, dimension(num_samples), intent(out) :: ti
    integer :: i, last_crossing = 0
    double precision :: dx_mod, dx
    double precision :: threshold
    num_crossings = 1 ! number of crossings
    threshold = -p2

    DO i = 2, num_samples
    ! find first positive crossing of phase, x = 0
      dx_mod = x_mod(i)-x_mod(i-1)
      IF (dx_mod < threshold) THEN
      ! only computes positiv crossings
        cross_idx(num_crossings) = i-1 ! saves value before the crossing
        last_crossing = cross_idx(num_crossings)
        EXIT
      END IF
    END DO

    DO i = i+1, num_samples
    ! ... now for the rest
      dx_mod = x_mod(i)-x_mod(i-1)
      dx     = x(i-1)-x(last_crossing)
      IF (dx_mod < threshold .AND. dx > -threshold) THEN
      ! only computes positiv crossings, and only if one oscillation was performed
        ti(num_crossings) = i-1-last_crossing
        num_crossings = num_crossings + 1
        cross_idx(num_crossings) = i-1 ! saves value before the crossing
        last_crossing = cross_idx(num_crossings)
      END IF
    END DO
  END SUBROUTINE poincare_times_no_false_returns

  SUBROUTINE poincare_times_interpolate (idx, ti, num_crossings, x, num_samples, idx_interp, ti_interp)

  ! ti(i) is the discrete time between two crossings
  ! idx(i) is the index of the step before 0
  ! x is phase, x[idx(i)] > 0.0
  ! times are the output where we will store the correct return times (= approx index)
  ! n: number of approximate zeros that were found

  integer, dimension(num_crossings), intent(in) :: idx, ti
  integer, intent(in) :: num_crossings
  double precision, dimension(num_samples), intent(in) :: x
  integer, intent(in) :: num_samples
  double precision, dimension(num_crossings), intent(out) :: idx_interp, ti_interp

    integer :: i, j, j1, JJ, JJ1
    double precision :: x_j, x_j1, x_jj, x_jj1
    DO i = 1, num_crossings
      j   = idx(i)     ! index before crossing
      j1  = idx(i)+1   ! index after crossing
      JJ  = j+ti(i)    ! index before return
      JJ1 = j+ti(i)+1  ! index after return

      !! Corresponding phases
      ! Before crossing are close to 'p'
      x_j   = x(j)-p
      x_jj  = x(JJ)-p
      ! After crossing are just above zero
      x_j1  = x(j1)
      x_jj1 = x(JJ1)

      idx_interp(i) = idx(i)- x_j/(x_j1-x_j)
      ti_interp(i)  = ti(i) + x_j/(x_j1-x_j)-x_jj/(x_jj1-x_jj)
    END DO
  END SUBROUTINE poincare_times_interpolate

END MODULE futils


Program dot_test
  Implicit None
  Real, Dimension( 1:100 ) :: a, b
  Real :: r
  a = 1.0
  b = 2.0
  !$omp parallel default( none ) shared( a, b, r )
  Call dot( a, b, r )
  Write( *, * ) r
  !$omp end parallel
Contains
  Subroutine dot( a, b, r )
    Real, Dimension( : ), Intent( In    ) :: a, b
    Real,                 Intent(   Out ) :: r
    Real, Save :: s
    Integer :: i
    !$omp single
    s = 0.0
    !$omp end single
    !$omp do reduction( +:s )
    Do i = 1, Size( a )
       s = s + a( i ) * b( i )
    End Do
    !$omp end do
    !$omp single
    r = s
    !$omp end single
  End Subroutine dot
End Program dot_test


subroutine streight_line(xzt,yzt,zzt, xst,yst,zst, ips, tout)
common/ray/ nodes,xray(1000),yray(1000),zray(1000)
common/ray_param/ds_ini,ds_part_min,bend_min0,bend_max0

dist = sqrt((xst-xzt)*(xst-xzt)+(yst-yzt)*(yst-yzt)+(zst-zzt)*(zst-zzt))

nodes = int_best(dist/ds_ini)+1
ds = dist / (nodes-1)
!write(*,*)' dist=',dist,' nodes=',nodes,' ds=',ds

if(nodes.eq.1) then
	nodes=2
	ds=dist
end if

!write(*,*)' ztr:',xzt,yzt
do inode = 1,nodes
	sss = ds * (inode-1)
	xray(inode) = xzt + sss * (xst-xzt)/dist
	yray(inode) = yzt + sss * (yst-yzt)/dist
	zray(inode) = zzt + sss * (zst-zzt)/dist
	!write(*,*) sss,xray(inode),yray(inode)
end do
!write(*,*)sss,' sta:',xst,yst

ddd=0
ttt=0
sss=0
do inode=1,nodes-1
	x1=xray(inode)
	x2=xray(inode+1)
	xm=(x1+x2)/2.

	y1=yray(inode)
	y2=yray(inode+1)
	ym=(y1+y2)/2.

	z1=zray(inode)
	z2=zray(inode+1)
	zm=(z1+z2)/2.

	ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1))
	!vvv=vrefmod (ym)
	vvv=velocity (xm,ym,zm,ips)
    !write(*,*)xm,ym,zm,vvv
	!write(*,*)' x 1 2=',x1,x2,' y 1 2=',y1,y2
	ttt=ttt+ds/vvv
	sss=sss+ds
end do
!write(*,*)' ttt=',ttt,' sss=',sss
!pause

tout=ttt

return
end


$ Declare
   SUBROUTINE Factorfw (a, c, B, W, fw)
!
! Correction term fw in SIF for eliptical flaws
! Fw according to BS 7910:2005 M.3 Flat plates
!
! Parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: a         ! Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c         ! FT = 2: Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B         ! FT = 2: Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W         ! Plate width
   DOUBLE PRECISION, INTENT(OUT)   :: fw        ! Correction term fw
!
! Declarations
   DOUBLE PRECISION                :: lambda
!
! Constants
   DOUBLE PRECISION                :: pi
   pi = 3.14159265358979D0
!
! Fw for copes
   IF (FlawType .EQ. 9) THEN
      fw = DSQRT(1.D0 / DCOS(pi * a / W ))
!
! Fw for edge flaws in plates BS 7910:2005 M.3.5
   ELSE IF (FlawType .EQ. 7) THEN
      fw = 1.D0
!
! Fw for surface flaws in bolts BS 7910:2005 M.6.3.2
   ELSE IF (FlawType .EQ. 6) THEN
      fw = 1.D0
!
! Fw for corner flaws in plates BS 7910:2005 M.3.6
   ELSE IF (FlawType .EQ. 5) THEN
	  lambda = (c / W) * DSQRT(a / B)
	  fw = 1.D0 - 0.2D0 * lambda + 9.4D0 * lambda**2 - 19.4D0 * lambda**3 + 27.1D0 * lambda**4
!
! Fw for semi-circular surface flaw in round bar BS 7910:2005 M.3.X
   ELSE IF (FlawType .EQ. 4) THEN
	  fw = 1.D0
!
! Fw for through-width flaws in plates BS 7910:2005 M.3.3
   ELSE IF (FlawType .EQ. 3) THEN
	  fw = 1.D0
!
! Fw for through-thickness flaws in plates BS 7910:2005 M.3.1
   ELSE IF (FlawType .EQ. 1) THEN
      fw = DSQRT(1.D0 / DCOS(pi * a / W ))
!
! Fw for surface flaws in plates BS 7910:2005 M.3.2.2
   ELSE IF (FlawType .EQ. 2) THEN
      IF (c/W .LE. 0.41D0) THEN
         fw = DSQRT(1.D0 / DCOS(pi * c / W * DSQRT(a / B)))
      ELSE
!         STOP 'Error calculating f_w in Subroutine GeometryFactorY: 2 c/W > 0.4'
         STOP 'Error calculating f_w in Subroutine GeometryFactorY: 2 c/W > 0.41'
      END IF
   ELSE
      STOP 'Error in Subroutine Factorfw: Unknown flawtype'
   END IF
!
! End subroutine
   RETURN
   END


module multid_slope_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  private

  public multid_slope

contains

! :::
! ::: ------------------------------------------------------------------
! :::

  subroutine multid_slope(q, q_lo, q_hi, ncomp, nc, &
                          flatn, &
                          dqx, dqy, qpd_lo, qpd_hi, &
                          dx, dy, &
                          ilo, jlo, ihi, jhi)

    use bl_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: q_lo(3), q_hi(3)
    integer, intent(in) :: qpd_lo(3), qpd_hi(3)
    integer, intent(in) :: ilo, jlo, ihi, jhi
    integer, intent(in) :: ncomp, nc

    real(rt)        , intent(in) :: dx, dy

    real(rt)        , intent(in) ::     q( q_lo(1): q_hi(1), q_lo(2): q_hi(2), ncomp)
    real(rt)        , intent(in) :: flatn( q_lo(1): q_hi(1), q_lo(2): q_hi(2))

    real(rt)        , intent(inout) :: dqx(qpd_lo(1):qpd_hi(1),qpd_lo(2):qpd_hi(2), ncomp)
    real(rt)        , intent(inout) :: dqy(qpd_lo(1):qpd_hi(1),qpd_lo(2):qpd_hi(2), ncomp)

    integer :: i, j, m, niter

    real(rt)        , allocatable :: q_nd(:,:)

    integer, parameter :: ill = 1, ilh = 2, irl = 3, irh = 4
    real(rt)         :: ss(4), ss_temp(4), min_ss(4), max_ss(4), diff(4)
    real(rt)         :: A_x, A_y, A_xy
    real(rt)         :: sumdiff, sgndiff, redfac, redmax, div
    real(rt)        , parameter :: eps = 1.e-10_rt
    integer :: kdp
    integer, parameter :: MAX_ITER = 3

    ! here we do a multidimensional reconstruction of the data, forming
    ! a bilinear polynomial:
    !     q(x,y) = A_xy (x-x_i)(y-y_i) + A_x (x-x_i) + A_y (y-y_i) + A_avg
    !
    ! First find the values at the nodes.  Here q_nd(i,j) will refer to
    ! a_{i-1/2,j-1/2}

    allocate(q_nd(q_lo(1):q_hi(1),q_lo(2):q_hi(2)))

    do j = jlo-2, jhi+3
       do i = ilo-2, ihi+3

          q_nd(i,j) = &
             (         q(i-2,j-2,nc) -  7.0e0_rt*(q(i-1,j-2,nc) + q(i,j-2,nc)) +       q(i+1,j-2,nc) + &
              (-7.0e0_rt)*q(i-2,j-1,nc) + 49.0e0_rt*(q(i-1,j-1,nc) + q(i,j-1,nc)) - 7.0e0_rt*q(i+1,j-1,nc) + &
              (-7.0e0_rt)*q(i-2,j  ,nc) + 49.0e0_rt*(q(i-1,j  ,nc) + q(i,j  ,nc)) - 7.0e0_rt*q(i+1,j  ,nc) + &
                       q(i-2,j+1,nc) -  7.0e0_rt*(q(i-1,j+1,nc) + q(i,j+1,nc)) +       q(i+1,j+1,nc))/ &
             144.0e0_rt

       enddo
    enddo

    ! now get the coefficients of the bilinear polynomial.  Here we loop
    ! ! over zone centers.
    do j = jlo-1, jhi+1
       do i = ilo-1, ihi+1

          ss(ill) = q_nd(i,j)     ! a_{i-1/2,j-1/2}
          ss(ilh) = q_nd(i,j+1)   ! a_{i-1/2,j+1/2}
          ss(irl) = q_nd(i+1,j)   ! a_{i+1/2,j-1/2}
          ss(irh) = q_nd(i+1,j+1) ! a_{i+1/2,j+1/2}

          A_x  = ((ss(irh) + ss(irl)) - (ss(ilh) + ss(ill)))/(2.0e0_rt*dx)
          A_y  = ((ss(ilh) + ss(irh)) - (ss(ill) + ss(irl)))/(2.0e0_rt*dy)
          A_xy = ((ss(irh) - ss(irl)) - (ss(ilh) - ss(ill)))/(dx*dy)

          ! check if we are within the cc-values
          ss_temp(ill) = q(i,j,nc) - HALF*dx*A_x - HALF*dy*A_y + 0.25e0_rt*dx*dy*A_xy
          ss_temp(ilh) = q(i,j,nc) - HALF*dx*A_x + HALF*dy*A_y - 0.25e0_rt*dx*dy*A_xy
          ss_temp(irl) = q(i,j,nc) + HALF*dx*A_x - HALF*dy*A_y - 0.25e0_rt*dx*dy*A_xy
          ss_temp(irh) = q(i,j,nc) + HALF*dx*A_x + HALF*dy*A_y + 0.25e0_rt*dx*dy*A_xy

          min_ss(ill) = min(q(i-1,j-1,nc), q(i,j-1,nc), q(i-1,j,nc), q(i,j,nc))
          max_ss(ill) = max(q(i-1,j-1,nc), q(i,j-1,nc), q(i-1,j,nc), q(i,j,nc))

          min_ss(ilh) = min(q(i-1,j+1,nc), q(i,j+1,nc), q(i-1,j,nc), q(i,j,nc))
          max_ss(ilh) = max(q(i-1,j+1,nc), q(i,j+1,nc), q(i-1,j,nc), q(i,j,nc))

          min_ss(irl) = min(q(i+1,j-1,nc), q(i,j-1,nc), q(i+1,j,nc), q(i,j,nc))
          max_ss(irl) = max(q(i+1,j-1,nc), q(i,j-1,nc), q(i+1,j,nc), q(i,j,nc))

          min_ss(irh) = min(q(i+1,j+1,nc), q(i,j+1,nc), q(i+1,j,nc), q(i,j,nc))
          max_ss(irh) = max(q(i+1,j+1,nc), q(i,j+1,nc), q(i+1,j,nc), q(i,j,nc))

          ! limit
          do m = 1, 4
             ss_temp(m) = max(min(ss_temp(m), max_ss(m)), min_ss(m))
          enddo

          do niter = 1, MAX_ITER
             sumdiff = (ss_temp(ill) + ss_temp(ilh) + &
                        ss_temp(irl) + ss_temp(irh)) - 4.0e0_rt*q(i,j,nc)
             sgndiff = sign(1.e0_rt,sumdiff)

             do m = 1, 4
                diff(m) = (ss_temp(m) - q(i,j,nc))*sgndiff
             enddo

             kdp = 0

             do m = 1, 4
                if (diff(m) > eps) kdp = kdp + 1
             enddo

             do m = 1, 4
                if (kdp < 1) then
                   div = 1.e0_rt
                else
                   div = dble(kdp)
                endif

                if (diff(m) > eps) then
                   redfac = sumdiff*sgndiff/div
                   kdp = kdp-1
                else
                   redfac = 0.0e0_rt
                endif

                if (sgndiff > 0.0e0_rt) then
                   redmax = ss_temp(m) - min_ss(m)
                else
                   redmax = max_ss(m) - ss_temp(m)
                endif

                redfac = min(redfac, redmax)
                sumdiff = sumdiff - redfac*sgndiff
                ss_temp(m) = ss_temp(m) - redfac*sgndiff
             enddo
          enddo

          ! construct the final slopes
          A_x  = ((ss_temp(irh) + ss_temp(irl)) - &
                  (ss_temp(ilh) + ss_temp(ill)))/(2.0e0_rt*dx)

          A_y  = ((ss_temp(ilh) + ss_temp(irh)) - &
                  (ss_temp(ill) + ss_temp(irl)))/(2.0e0_rt*dy)

          A_xy = ((ss_temp(irh) - ss_temp(irl)) - &
                  (ss_temp(ilh) - ss_temp(ill)))/(dx*dy)

          ! now construct the limited differences in x and y
          dqx(i,j,nc) = flatn(i,j)*A_x*dx
          dqy(i,j,nc) = flatn(i,j)*A_y*dy

       enddo
    enddo

    deallocate(q_nd)

  end subroutine multid_slope

end module multid_slope_module


      subroutine dittdrein(p,l1,l2,costhdd)
      implicit none
      include 'constants.f'
      integer j,l1,l2
      double precision costhdd,p(mxpart,4),pt,ptem,ptep,xl
      double precision pem(4),pep(4),psum(4)
      double precision p_cm(4)

      do j=1,4
      pem(j)=p(l1,j)
      pep(j)=p(l2,j)
      psum(j)=pem(j)+pep(j)
      enddo

      ptem=pt(l1,p)
      ptep=pt(l2,p)

      if (ptem .gt. ptep) then
      call boosta(psum,pem,p_cm)
      else
      call boosta(psum,pep,p_cm)
      endif

      xl=sqrt((psum(1)**2+psum(2)**2+psum(3)**2)
     .       *(p_cm(1)**2+p_cm(2)**2+p_cm(3)**2))
      costhdd=(p_cm(1)*psum(1)+p_cm(2)*psum(2)+p_cm(3)*psum(3))/xl

      return
      end


!-----------------------------------------------------------------------
!     Subroutine:    chisq_helicity_ornl
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          06/28/2012
!     Description:   Calculate ratio of magnetic energies in modes with
!                    undesirable helicities to the energy in modes with
!                    the desired helicity (bnorm). By surf
!-----------------------------------------------------------------------
      SUBROUTINE chisq_helicity_ornl(target,sigma,niter,iflag)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stellopt_runtime
      USE stellopt_targets
      USE equil_vals
      USE read_boozer_mod
      IMPLICIT NONE

!-----------------------------------------------------------------------
!     Input/Output Variables
!
!-----------------------------------------------------------------------
      REAL(rprec), INTENT(in)    ::  target(nsd)
      REAL(rprec), INTENT(in)    ::  sigma(nsd)
      INTEGER,     INTENT(in)    ::  niter
      INTEGER,     INTENT(inout) ::  iflag

!-----------------------------------------------------------------------
!     Local Variables
!        lreset_s    Gets set to true if using R,PHI,Z Specification
!        ik          Dummy index
!        ier         Error Flag
!        te_val      Holds profile evaulation
!-----------------------------------------------------------------------
      LOGICAL :: lsym
      INTEGER :: dex, ik, mn, n, m, k_heli, l_heli, num0, n1, n2
      REAL(rprec) :: bnorm, bmax, bmn, rad_sigma, sj, val
      LOGICAL, ALLOCATABLE :: lmask(:), nlmask(:)
      REAL(rprec), ALLOCATABLE :: rad_wegt(:)
!----------------------------------------------------------------------
!     BEGIN SUBROUTINE
!----------------------------------------------------------------------
      IF (iflag < 0 ) RETURN
      IF (lasym) STOP 'ERROR: Helicity targeting requires lasym = .FALSE.'
      dex = COUNT(sigma < bigno)
      l_heli = NINT(REAL(helicity))
      k_heli = NINT(AIMAG(helicity))
      IF (niter >= 0) THEN
         ! Get total number of modes for output
         IF (iflag == 1) THEN
            WRITE(iunit_out,'(A,2(2X,I8))') 'HELICITY ',dex,4
            WRITE(iunit_out,'(A)') 'TARGET  SIGMA  VALS  BNORM'
            CALL FLUSH(iunit_out)
         END IF
         ! Now calculate chi_sq
         ALLOCATE(lmask(mnboz_b),rad_wegt(mnboz_b),nlmask(mnboz_b))
         lmask = .FALSE.
         IF (k_heli == 0) THEN  !QAS
            WHERE (ixn_b == 0)  lmask = .TRUE.
         ELSE IF (l_heli == 0) THEN !QPS
            WHERE (ixm_b == 0) lmask = .TRUE.
         ELSE ! Helical symmetry
            WHERE (MOD(ixm_b,l_heli) == 0) lmask = .TRUE.
            WHERE ((ixm_b*k_heli + ixn_b*l_heli/nfp) /= 0) lmask = .FALSE.
         END IF
         nlmask = .TRUE.
         WHERE(lmask) nlmask = .FALSE.
         DO ik = 1, nsd
            IF (sigma(ik) >= bigno) CYCLE
            bmax  = MAXVAL(ABS(bmnc_b(1:mnboz_b,ik)))
            sj = (real(ik,rprec) - 1.5_dp)/REAL((ns_b-1),rprec)            !!This is correct (SPH)
            val = 0.0
            bnorm = 0.0
            rad_wegt = 1
            IF (sigma(ik) < 0) THEN
               rad_wegt = sj*sj
               WHERE(ixm_b < 3) rad_wegt = sj
               WHERE(ixm_b == 3) rad_wegt = sj**1.5
            END IF
            bnorm = SUM(bmnc_b(:,ik)**2,MASK=lmask)
            val   = SUM((bmnc_b(:,ik)/rad_wegt)**2,MASK=nlmask)
!            DO mn = 1, mnboz_b
!               n = ixn_b(mn)/nfp_b
!               m = ixm_b(mn)
!               bmn = bmnc_b(mn,ik)
!               ! Target for minimization Bmn-s with helicities other than the one desired
!               ! General Helical Symmetry: mu - nv ~ Y(lu + kv) for integers Y != 0 (n,k in fp units)
!               ! HELICITY = (1,0)  !QA
!               !          = (0,1)  !QP
!               !          = (1,-1) !QH (l,k) (m*k+n*l)
!               lsym = .FALSE.
!               IF (k_heli == 0) THEN               !!quasi-axisymmetry
!                  IF (n == 0) lsym = .TRUE.
!               ELSE IF (l_heli == 0) THEN          !!quasi-poloidal symmetry
!                  IF (m == 0) lsym = .TRUE.
!               ELSE IF (MOD(m,l_heli) == 0) THEN   !!quasi-helical symmetry (lu + kv)
!                  IF ((m*k_heli+n*l_heli) == 0) lsym = .TRUE.
!               END IF
!               ! mimic's oak ridge system
!               rad_sigma = 1
!               IF (sigma(ik) < 0.0) THEN
!                  rad_sigma = 1
!               ELSE IF (m < 3) THEN
!                  rad_sigma = sj
!               ELSE IF (m == 3) THEN
!                  rad_sigma = sj**1.5
!               ELSE
!                  rad_sigma = sj*sj
!               END IF
!               IF (lsym) THEN
!                  bnorm = bnorm + bmn*bmn
!               ELSE
!                  val = val + bmn*bmn/rad_sigma
!               END IF
!            END DO
            IF (bnorm == 0.0) bnorm = bmax*bmax
            mtargets = mtargets + 1
            targets(mtargets) = target(ik)
            sigmas(mtargets)  = ABS(sigma(ik))
            vals(mtargets)    = SQRT(ABS(val/bnorm))
            IF (iflag == 1) WRITE(iunit_out,'(4ES22.12E3)') targets(mtargets),sigmas(mtargets),vals(mtargets),SQRT(bnorm)
         END DO
         DEALLOCATE(lmask, rad_wegt, nlmask)
      ELSE
         DO ik = 1, nsd
            IF (sigma(ik) < bigno) THEN
               mtargets = mtargets + 1
               lbooz(ik) = .TRUE.
               IF (niter == -2) target_dex(mtargets) = jtarget_helicity
            END IF
         END DO
      END IF
      RETURN
!----------------------------------------------------------------------
!     END SUBROUTINE
!----------------------------------------------------------------------
      END SUBROUTINE chisq_helicity_ornl


program main
    use parameters
    use cudafor
    use curand
    use randomf
    use forcec, only: force
    use positions, only: position
    use utils
    use, intrinsic :: iso_fortran_env, only: output_unit

    implicit none

    ! CUDA variables
    type(dim3) :: grid, tBlock
    integer :: numSMs
    integer :: istat
    type(curandGenerator) :: gen

    ! General arrays, either CUDA or host
    real, allocatable, device :: randv(:)
    real, allocatable, device :: fx_d(:), fy_d(:), fz_d(:)
    real, allocatable, managed :: x(:), y(:), z(:)
    real, allocatable, managed :: enerpot(:), zfac(:)

    ! Local variables
    real :: d, virial, epotn
    integer :: i, istep, nprom, j, u
    real :: dv, fnorm, pressure, compressibility
    integer :: limT, limG, pbc, avefreq, threenp
    logical :: exists, init_config

    !! Read the inputs from the file
    call parse_input("input.in", limG, limT, init_config)
    ! Variable initialization
    rho = 6.0 * phi / pi
    boxl = (real(np) / rho)**(1.0/3.0)
    rc = boxl / 2.0
    threenp = 3 * np
    d = (1.0 / rho)**(1.0/3.0) ! Interparticle distance
    avefreq = 10000 ! Average frequency
    ! Always start with PBC
    pbc = 1

    ! Initialize arrays
    allocate(x(np), y(np), z(np), source=0.0)
    allocate(enerpot(np), zfac(np), source=0.0)
    allocate(randv(threenp), source=0.0)
    allocate(fx_d(np), fy_d(np), fz_d(np), source=0.0)

    ! Show important information to screen
    write(unit=output_unit, fmt='(a, 8f)'), 'The length of the box is: ', boxl
    write(unit=output_unit, fmt='(a, 8f)'), 'The mean interparticle distance is: ', d
    write(unit=output_unit, fmt='(a, 8f)'), 'Cut radius: ', rc
    write(unit=output_unit, fmt='(a, 8f)'), 'Reduced temperature: ', ktemp
    write(unit=output_unit, fmt='(a, i)'), 'Number of particles: ', np

    ! Initialize CUDA kernel variables
    tBlock = dim3(blksz, 1, 1)
    istat = cudaDeviceGetAttribute(numSMs, cudaDevAttrMultiProcessorCount, 0)
    grid = 32 * numSMs
    write(unit=output_unit, fmt='(2i8)') grid%x, numSMs

    ! Check if there is a previous configuration
    inquire(file='finalconBD.dat', exist=exists)
    ! If so, load it
    if (exists .and. init_config) then
        open(newunit=u, file='finalconBD.dat', status="old", action="read")
        write(unit=output_unit, fmt='(a)') 'Reading positions from file...'
        do i = 1, np
            read(u, *) x(i), y(i), z(i)
        end do
        close(u)
    ! If not, create a new configuration
    else
        call iniconfig(x, y, z, d)
    end if
    ! Energy of the initial configuration
    call force <<< grid, tBlock >>> (x, y, z, fx_d, fy_d, fz_d, enerpot, zfac)
    istat = cudaDeviceSynchronize()
    if ( istat .ne. 0 ) then
        write(unit=u, fmt='(a)') 'Error with GPU!'
    end if
    write(unit=output_unit, fmt='(a,8f)') 'E/N=', sum(enerpot) / real(np)

    ! Initialize the PRNG
    call initialize_rng(gen)

    open(newunit=u, file='energy_BD_therm.dat', status='unknown')

    write(unit=output_unit, fmt='(a)') 'Step, Upot, Press, Z'
    do istep = 1, limT
        ! Compute the random numbers
        call fill_vec(randv, gen, threenp)

        call position <<< grid, tBlock >>> (x, y, z, fx_d, fy_d, fz_d, randv, pbc)
        call force <<< grid, tBlock >>> (x, y, z, fx_d, fy_d, fz_d, enerpot, zfac)

        if (mod(istep, avefreq) == 0) then
            ! Compute the energy per particle
            epotn = sum(enerpot) / real(np)

            ! Compute the virial, 3.0 is because of the dimensionality
            virial = sum(zfac) / 3.0

            ! Compute the pressure from the system
            pressure = (rho * ktemp) + (virial / boxl**3)

            ! Compute the compressibility factor
            compressibility = pressure / (rho * ktemp)

            ! Print to screen
            write(unit=output_unit, fmt='(i,4f16.8)') istep, epotn, pressure, &
                compressibility
            ! Print to file 'u'
            write(unit=u, fmt='(i,3f16.8)') istep, epotn, pressure, compressibility
        end if
    end do
    close (u)

    write(unit=output_unit, fmt='(a)') 'The system has thermalized'

    ! Save positions to file for re-use in other runs
    open(newunit=u, file='finalconBD.dat', status='unknown')
    do i = 1, np
        write(u, '(3f16.8)') x(i), y(i), z(i)
    end do
    close(u)

    ! Open file for production run
    open(newunit=u, file='energy_BD_prod.dat', status='unknown')

    ! Turn off periodic boundary conditions
    pbc = 0
    write(unit=output_unit, fmt='(a)') 'Step, Upot, Press, Z'
    do istep = 1, limG
        ! Compute the random numbers
        call fill_vec(randv, gen, threenp)

        call position <<< grid, tBlock >>> (x, y, z, fx_d, fy_d, fz_d, randv, pbc)
        call force <<< grid, tBlock >>> (x, y, z, fx_d, fy_d, fz_d, enerpot, zfac)

        if (mod(istep, 1000) == 0) then
            ! Compute the energy per particle
            epotn = sum(enerpot) / real(np)

            ! Compute the virial, 3.0 is because of the dimensionality
            virial = sum(zfac) / 3.0

            ! Compute the pressure from the system
            pressure = (rho * ktemp) + (virial / boxl**3)

            ! Compute the compressibility factor
            compressibility = pressure / (rho * ktemp)

            ! Print to screen
            write(unit=output_unit, fmt='(i,4f16.8)') istep, epotn, pressure, &
                compressibility
            ! Print to file 'u'
            write(unit=u, fmt='(i,3f16.8)') istep, epotn, pressure, compressibility
            ! Save snapshots to file
            call save_timeseries("msd_data/positions_p=", x, y, z)
            ! Save positions to files
            call save_snapshots("snapshots/snapshot_p=", x, y, z, istep)
        end if
    end do

    ! Close file for production
    close(u)
end program main